source: IOIPSL/trunk/src/getincom.f90 @ 536

Last change on this file since 536 was 536, checked in by bellier, 16 years ago

New version with dynamic extension
  • Property svn:keywords set to Id
File size: 58.4 KB
Line 
1MODULE getincom
2!-
3!$Id$
4!-
5! This software is governed by the CeCILL license
6! See IOIPSL/IOIPSL_License_CeCILL.txt
7!---------------------------------------------------------------------
8USE errioipsl, ONLY : ipslerr
9USE stringop, &
10 &   ONLY : nocomma,cmpblank,strlowercase
11!-
12IMPLICIT NONE
13!-
14PRIVATE
15PUBLIC :: getin, getin_dump
16!-
17INTERFACE getin
18!!--------------------------------------------------------------------
19!! The "getin" routines get a variable.
20!! We first check if we find it in the database
21!! and if not we get it from the run.def file.
22!!
23!! SUBROUTINE getin (target,ret_val)
24!!
25!! INPUT
26!!
27!! (C) target : Name of the variable
28!!
29!! OUTPUT
30!!
31!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
32!!                     that will contain the (standard)
33!!                     integer/real/character/logical values
34!!--------------------------------------------------------------------
35  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
36 &                 getinis, getini1d, getini2d, &
37 &                 getincs, getinc1d, getinc2d, &
38 &                 getinls, getinl1d, getinl2d
39END INTERFACE
40!-
41!!--------------------------------------------------------------------
42!! The "getin_dump" routine will dump the content of the database
43!! into a file which has the same format as the run.def file.
44!! The idea is that the user can see which parameters were used
45!! and re-use the file for another run.
46!!
47!!  SUBROUTINE getin_dump (fileprefix)
48!!
49!! OPTIONAL INPUT argument
50!!
51!! (C) fileprefix : allows the user to change the name of the file
52!!                  in which the data will be archived
53!!--------------------------------------------------------------------
54!-
55  INTEGER,PARAMETER :: max_files=100
56  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
57  INTEGER,SAVE      :: nbfiles
58!-
59  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
60  INTEGER,SAVE :: nb_lines,i_txtsize=0
61  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
62  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
63  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
64!-
65  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
66  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
67!-
68! The data base of parameters
69!-
70  INTEGER,PARAMETER :: memslabs=200
71  INTEGER,PARAMETER :: compress_lim=20
72!-
73  INTEGER,SAVE :: nb_keys=0
74  INTEGER,SAVE :: keymemsize=0
75!-
76! keystr definition
77! name of a key
78!-
79! keystatus definition
80! keystatus = 1 : Value comes from run.def
81! keystatus = 2 : Default value is used
82! keystatus = 3 : Some vector elements were taken from default
83!-
84! keytype definition
85! keytype = 1 : Integer
86! keytype = 2 : Real
87! keytype = 3 : Character
88! keytype = 4 : Logical
89!-
90  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
91!-
92! Allow compression for keys (only for integer and real)
93! keycompress < 0 : not compressed
94! keycompress > 0 : number of repeat of the value
95!-
96TYPE :: t_key
97  CHARACTER(LEN=l_n) :: keystr
98  INTEGER :: keystatus, keytype, keycompress, &
99 &           keyfromfile, keymemstart, keymemlen
100END TYPE t_key
101!-
102  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
103!-
104  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
105  INTEGER,SAVE :: i_memsize=0, i_mempos=0
106  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
107  INTEGER,SAVE :: r_memsize=0, r_mempos=0
108  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
109  INTEGER,SAVE :: c_memsize=0, c_mempos=0
110  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
111  INTEGER,SAVE :: l_memsize=0, l_mempos=0
112!-
113CONTAINS
114!-
115!=== INTEGER INTERFACE
116!-
117SUBROUTINE getinis (target,ret_val)
118!---------------------------------------------------------------------
119  IMPLICIT NONE
120!-
121  CHARACTER(LEN=*) :: target
122  INTEGER :: ret_val
123!-
124  INTEGER,DIMENSION(1) :: tmp_ret_val
125  INTEGER :: pos,status=0,fileorig
126!---------------------------------------------------------------------
127!-
128! Do we have this target in our database ?
129!-
130  CALL get_findkey (1,target,pos)
131!-
132  tmp_ret_val(1) = ret_val
133!-
134  IF (pos < 0) THEN
135!-- Get the information out of the file
136    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
137!-- Put the data into the database
138    CALL get_wdb &
139 &   (target,status,fileorig,1,i_val=tmp_ret_val)
140  ELSE
141!-- Get the value out of the database
142    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
143  ENDIF
144  ret_val = tmp_ret_val(1)
145!---------------------
146END SUBROUTINE getinis
147!===
148SUBROUTINE getini1d (target,ret_val)
149!---------------------------------------------------------------------
150  IMPLICIT NONE
151!-
152  CHARACTER(LEN=*) :: target
153  INTEGER,DIMENSION(:) :: ret_val
154!-
155  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
156  INTEGER,SAVE :: tmp_ret_size = 0
157  INTEGER :: pos,size_of_in,status=0,fileorig
158!---------------------------------------------------------------------
159!-
160! Do we have this target in our database ?
161!-
162  CALL get_findkey (1,target,pos)
163!-
164  size_of_in = SIZE(ret_val)
165  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
166    ALLOCATE (tmp_ret_val(size_of_in))
167  ELSE IF (size_of_in > tmp_ret_size) THEN
168    DEALLOCATE (tmp_ret_val)
169    ALLOCATE (tmp_ret_val(size_of_in))
170    tmp_ret_size = size_of_in
171  ENDIF
172  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
173!-
174  IF (pos < 0) THEN
175!-- Get the information out of the file
176    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
177!-- Put the data into the database
178    CALL get_wdb &
179 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
180  ELSE
181!-- Get the value out of the database
182    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
183  ENDIF
184  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
185!----------------------
186END SUBROUTINE getini1d
187!===
188SUBROUTINE getini2d (target,ret_val)
189!---------------------------------------------------------------------
190  IMPLICIT NONE
191!-
192  CHARACTER(LEN=*) :: target
193  INTEGER,DIMENSION(:,:) :: ret_val
194!-
195  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
196  INTEGER,SAVE :: tmp_ret_size = 0
197  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
198  INTEGER :: jl,jj,ji
199!---------------------------------------------------------------------
200!-
201! Do we have this target in our database ?
202!-
203  CALL get_findkey (1,target,pos)
204!-
205  size_of_in = SIZE(ret_val)
206  size_1 = SIZE(ret_val,1)
207  size_2 = SIZE(ret_val,2)
208  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
209    ALLOCATE (tmp_ret_val(size_of_in))
210  ELSE IF (size_of_in > tmp_ret_size) THEN
211    DEALLOCATE (tmp_ret_val)
212    ALLOCATE (tmp_ret_val(size_of_in))
213    tmp_ret_size = size_of_in
214  ENDIF
215!-
216  jl=0
217  DO jj=1,size_2
218    DO ji=1,size_1
219      jl=jl+1
220      tmp_ret_val(jl) = ret_val(ji,jj)
221    ENDDO
222  ENDDO
223!-
224  IF (pos < 0) THEN
225!-- Get the information out of the file
226    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
227!-- Put the data into the database
228    CALL get_wdb &
229 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
230  ELSE
231!-- Get the value out of the database
232    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
233  ENDIF
234!-
235  jl=0
236  DO jj=1,size_2
237    DO ji=1,size_1
238      jl=jl+1
239      ret_val(ji,jj) = tmp_ret_val(jl)
240    ENDDO
241  ENDDO
242!----------------------
243END SUBROUTINE getini2d
244!-
245!=== REAL INTERFACE
246!-
247SUBROUTINE getinrs (target,ret_val)
248!---------------------------------------------------------------------
249  IMPLICIT NONE
250!-
251  CHARACTER(LEN=*) :: target
252  REAL :: ret_val
253!-
254  REAL,DIMENSION(1) :: tmp_ret_val
255  INTEGER :: pos,status=0,fileorig
256!---------------------------------------------------------------------
257!-
258! Do we have this target in our database ?
259!-
260  CALL get_findkey (1,target,pos)
261!-
262  tmp_ret_val(1) = ret_val
263!-
264  IF (pos < 0) THEN
265!-- Get the information out of the file
266    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
267!-- Put the data into the database
268    CALL get_wdb &
269 &   (target,status,fileorig,1,r_val=tmp_ret_val)
270  ELSE
271!-- Get the value out of the database
272    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
273  ENDIF
274  ret_val = tmp_ret_val(1)
275!---------------------
276END SUBROUTINE getinrs
277!===
278SUBROUTINE getinr1d (target,ret_val)
279!---------------------------------------------------------------------
280  IMPLICIT NONE
281!-
282  CHARACTER(LEN=*) :: target
283  REAL,DIMENSION(:) :: ret_val
284!-
285  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
286  INTEGER,SAVE :: tmp_ret_size = 0
287  INTEGER :: pos,size_of_in,status=0,fileorig
288!---------------------------------------------------------------------
289!-
290! Do we have this target in our database ?
291!-
292  CALL get_findkey (1,target,pos)
293!-
294  size_of_in = SIZE(ret_val)
295  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
296    ALLOCATE (tmp_ret_val(size_of_in))
297  ELSE IF (size_of_in > tmp_ret_size) THEN
298    DEALLOCATE (tmp_ret_val)
299    ALLOCATE (tmp_ret_val(size_of_in))
300    tmp_ret_size = size_of_in
301  ENDIF
302  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
303!-
304  IF (pos < 0) THEN
305!-- Get the information out of the file
306    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
307!-- Put the data into the database
308    CALL get_wdb &
309 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
310  ELSE
311!-- Get the value out of the database
312    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
313  ENDIF
314  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
315!----------------------
316END SUBROUTINE getinr1d
317!===
318SUBROUTINE getinr2d (target,ret_val)
319!---------------------------------------------------------------------
320  IMPLICIT NONE
321!-
322  CHARACTER(LEN=*) :: target
323  REAL,DIMENSION(:,:) :: ret_val
324!-
325  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
326  INTEGER,SAVE :: tmp_ret_size = 0
327  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
328  INTEGER :: jl,jj,ji
329!---------------------------------------------------------------------
330!-
331! Do we have this target in our database ?
332!-
333  CALL get_findkey (1,target,pos)
334!-
335  size_of_in = SIZE(ret_val)
336  size_1 = SIZE(ret_val,1)
337  size_2 = SIZE(ret_val,2)
338  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
339    ALLOCATE (tmp_ret_val(size_of_in))
340  ELSE IF (size_of_in > tmp_ret_size) THEN
341    DEALLOCATE (tmp_ret_val)
342    ALLOCATE (tmp_ret_val(size_of_in))
343    tmp_ret_size = size_of_in
344  ENDIF
345!-
346  jl=0
347  DO jj=1,size_2
348    DO ji=1,size_1
349      jl=jl+1
350      tmp_ret_val(jl) = ret_val(ji,jj)
351    ENDDO
352  ENDDO
353!-
354  IF (pos < 0) THEN
355!-- Get the information out of the file
356    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
357!-- Put the data into the database
358    CALL get_wdb &
359 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
360  ELSE
361!-- Get the value out of the database
362    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
363  ENDIF
364!-
365  jl=0
366  DO jj=1,size_2
367    DO ji=1,size_1
368      jl=jl+1
369      ret_val(ji,jj) = tmp_ret_val(jl)
370    ENDDO
371  ENDDO
372!----------------------
373END SUBROUTINE getinr2d
374!-
375!=== CHARACTER INTERFACE
376!-
377SUBROUTINE getincs (target,ret_val)
378!---------------------------------------------------------------------
379  IMPLICIT NONE
380!-
381  CHARACTER(LEN=*) :: target
382  CHARACTER(LEN=*) :: ret_val
383!-
384  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
385  INTEGER :: pos,status=0,fileorig
386!---------------------------------------------------------------------
387!-
388! Do we have this target in our database ?
389!-
390  CALL get_findkey (1,target,pos)
391!-
392  tmp_ret_val(1) = ret_val
393!-
394  IF (pos < 0) THEN
395!-- Get the information out of the file
396    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
397!-- Put the data into the database
398    CALL get_wdb &
399 &   (target,status,fileorig,1,c_val=tmp_ret_val)
400  ELSE
401!-- Get the value out of the database
402    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
403  ENDIF
404  ret_val = tmp_ret_val(1)
405!---------------------
406END SUBROUTINE getincs
407!===
408SUBROUTINE getinc1d (target,ret_val)
409!---------------------------------------------------------------------
410  IMPLICIT NONE
411!-
412  CHARACTER(LEN=*) :: target
413  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
414!-
415  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
416  INTEGER,SAVE :: tmp_ret_size = 0
417  INTEGER :: pos,size_of_in,status=0,fileorig
418!---------------------------------------------------------------------
419!-
420! Do we have this target in our database ?
421!-
422  CALL get_findkey (1,target,pos)
423!-
424  size_of_in = SIZE(ret_val)
425  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
426    ALLOCATE (tmp_ret_val(size_of_in))
427  ELSE IF (size_of_in > tmp_ret_size) THEN
428    DEALLOCATE (tmp_ret_val)
429    ALLOCATE (tmp_ret_val(size_of_in))
430    tmp_ret_size = size_of_in
431  ENDIF
432  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
433!-
434  IF (pos < 0) THEN
435!-- Get the information out of the file
436    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
437!-- Put the data into the database
438    CALL get_wdb &
439 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
440  ELSE
441!-- Get the value out of the database
442    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
443  ENDIF
444  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
445!----------------------
446END SUBROUTINE getinc1d
447!===
448SUBROUTINE getinc2d (target,ret_val)
449!---------------------------------------------------------------------
450  IMPLICIT NONE
451!-
452  CHARACTER(LEN=*) :: target
453  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
454!-
455  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
456  INTEGER,SAVE :: tmp_ret_size = 0
457  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
458  INTEGER :: jl,jj,ji
459!---------------------------------------------------------------------
460!-
461! Do we have this target in our database ?
462!-
463  CALL get_findkey (1,target,pos)
464!-
465  size_of_in = SIZE(ret_val)
466  size_1 = SIZE(ret_val,1)
467  size_2 = SIZE(ret_val,2)
468  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
469    ALLOCATE (tmp_ret_val(size_of_in))
470  ELSE IF (size_of_in > tmp_ret_size) THEN
471    DEALLOCATE (tmp_ret_val)
472    ALLOCATE (tmp_ret_val(size_of_in))
473    tmp_ret_size = size_of_in
474  ENDIF
475!-
476  jl=0
477  DO jj=1,size_2
478    DO ji=1,size_1
479      jl=jl+1
480      tmp_ret_val(jl) = ret_val(ji,jj)
481    ENDDO
482  ENDDO
483!-
484  IF (pos < 0) THEN
485!-- Get the information out of the file
486    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
487!-- Put the data into the database
488    CALL get_wdb &
489 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
490  ELSE
491!-- Get the value out of the database
492    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
493  ENDIF
494!-
495  jl=0
496  DO jj=1,size_2
497    DO ji=1,size_1
498      jl=jl+1
499      ret_val(ji,jj) = tmp_ret_val(jl)
500    ENDDO
501  ENDDO
502!----------------------
503END SUBROUTINE getinc2d
504!-
505!=== LOGICAL INTERFACE
506!-
507SUBROUTINE getinls (target,ret_val)
508!---------------------------------------------------------------------
509  IMPLICIT NONE
510!-
511  CHARACTER(LEN=*) :: target
512  LOGICAL :: ret_val
513!-
514  LOGICAL,DIMENSION(1) :: tmp_ret_val
515  INTEGER :: pos,status=0,fileorig
516!---------------------------------------------------------------------
517!-
518! Do we have this target in our database ?
519!-
520  CALL get_findkey (1,target,pos)
521!-
522  tmp_ret_val(1) = ret_val
523!-
524  IF (pos < 0) THEN
525!-- Get the information out of the file
526    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
527!-- Put the data into the database
528    CALL get_wdb &
529 &   (target,status,fileorig,1,l_val=tmp_ret_val)
530  ELSE
531!-- Get the value out of the database
532    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
533  ENDIF
534  ret_val = tmp_ret_val(1)
535!---------------------
536END SUBROUTINE getinls
537!===
538SUBROUTINE getinl1d (target,ret_val)
539!---------------------------------------------------------------------
540  IMPLICIT NONE
541!-
542  CHARACTER(LEN=*) :: target
543  LOGICAL,DIMENSION(:) :: ret_val
544!-
545  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
546  INTEGER,SAVE :: tmp_ret_size = 0
547  INTEGER :: pos,size_of_in,status=0,fileorig
548!---------------------------------------------------------------------
549!-
550! Do we have this target in our database ?
551!-
552  CALL get_findkey (1,target,pos)
553!-
554  size_of_in = SIZE(ret_val)
555  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
556    ALLOCATE (tmp_ret_val(size_of_in))
557  ELSE IF (size_of_in > tmp_ret_size) THEN
558    DEALLOCATE (tmp_ret_val)
559    ALLOCATE (tmp_ret_val(size_of_in))
560    tmp_ret_size = size_of_in
561  ENDIF
562  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
563!-
564  IF (pos < 0) THEN
565!-- Get the information out of the file
566    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
567!-- Put the data into the database
568    CALL get_wdb &
569 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
570  ELSE
571!-- Get the value out of the database
572    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
573  ENDIF
574  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
575!----------------------
576END SUBROUTINE getinl1d
577!===
578SUBROUTINE getinl2d (target,ret_val)
579!---------------------------------------------------------------------
580  IMPLICIT NONE
581!-
582  CHARACTER(LEN=*) :: target
583  LOGICAL,DIMENSION(:,:) :: ret_val
584!-
585  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
586  INTEGER,SAVE :: tmp_ret_size = 0
587  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
588  INTEGER :: jl,jj,ji
589!---------------------------------------------------------------------
590!-
591! Do we have this target in our database ?
592!-
593  CALL get_findkey (1,target,pos)
594!-
595  size_of_in = SIZE(ret_val)
596  size_1 = SIZE(ret_val,1)
597  size_2 = SIZE(ret_val,2)
598  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
599    ALLOCATE (tmp_ret_val(size_of_in))
600  ELSE IF (size_of_in > tmp_ret_size) THEN
601    DEALLOCATE (tmp_ret_val)
602    ALLOCATE (tmp_ret_val(size_of_in))
603    tmp_ret_size = size_of_in
604  ENDIF
605!-
606  jl=0
607  DO jj=1,size_2
608    DO ji=1,size_1
609      jl=jl+1
610      tmp_ret_val(jl) = ret_val(ji,jj)
611    ENDDO
612  ENDDO
613!-
614  IF (pos < 0) THEN
615!-- Get the information out of the file
616    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
617!-- Put the data into the database
618    CALL get_wdb &
619 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
620  ELSE
621!-- Get the value out of the database
622    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
623  ENDIF
624!-
625  jl=0
626  DO jj=1,size_2
627    DO ji=1,size_1
628      jl=jl+1
629      ret_val(ji,jj) = tmp_ret_val(jl)
630    ENDDO
631  ENDDO
632!----------------------
633END SUBROUTINE getinl2d
634!-
635!=== Generic file/database INTERFACE
636!-
637SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
638!---------------------------------------------------------------------
639!- Subroutine that will extract from the file the values
640!- attributed to the keyword target
641!-
642!- (C) target    : target for which we will look in the file
643!- (I) status    : tells us from where we obtained the data
644!- (I) fileorig  : index of the file from which the key comes
645!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
646!- (R) r_val(:)  : REAL(nb_to_ret)      values
647!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
648!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
649!---------------------------------------------------------------------
650  IMPLICIT NONE
651!-
652  CHARACTER(LEN=*) :: target
653  INTEGER,INTENT(OUT) :: status,fileorig
654  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
655  REAL,DIMENSION(:),OPTIONAL             :: r_val
656  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
657  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
658!-
659  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
660  CHARACTER(LEN=n_d_fmt)  :: cnt
661  CHARACTER(LEN=80) :: str_READ,str_READ_lower
662  CHARACTER(LEN=9)  :: c_vtyp
663  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
664  LOGICAL :: def_beha,compressed
665  CHARACTER(LEN=10) :: c_fmt
666  INTEGER :: i_cmpval
667  REAL    :: r_cmpval
668  INTEGER :: ipos_tr,ipos_fl
669!---------------------------------------------------------------------
670!-
671! Get the type of the argument
672  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
673  SELECT CASE (k_typ)
674  CASE(k_i)
675    nb_to_ret = SIZE(i_val)
676  CASE(k_r)
677    nb_to_ret = SIZE(r_val)
678  CASE(k_c)
679    nb_to_ret = SIZE(c_val)
680  CASE(k_l)
681    nb_to_ret = SIZE(l_val)
682  CASE DEFAULT
683    CALL ipslerr (3,'get_fil', &
684 &   'Internal error','Unknown type of data',' ')
685  END SELECT
686!-
687! Read the file(s)
688  CALL getin_read
689!-
690! Allocate and initialize the memory we need
691  ALLOCATE(found(nb_to_ret))
692  found(:) = .FALSE.
693!-
694! See what we find in the files read
695  DO it=1,nb_to_ret
696!---
697!-- First try the target as it is
698    CALL get_findkey (2,target,pos)
699!---
700!-- Another try
701!---
702    IF (pos < 0) THEN
703      WRITE(UNIT=cnt,FMT=c_i_fmt) it
704      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
705    ENDIF
706!---
707!-- We dont know from which file the target could come.
708!-- Thus by default we attribute it to the first file :
709    fileorig = 1
710!---
711    IF (pos > 0) THEN
712!-----
713      found(it) = .TRUE.
714      fileorig = fromfile(pos)
715!-----
716!---- DECODE
717!-----
718      str_READ = ADJUSTL(fichier(pos))
719      str_READ_lower = str_READ
720      CALL strlowercase (str_READ_lower)
721!-----
722      IF (    (TRIM(str_READ_lower) == 'def')     &
723 &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
724        def_beha = .TRUE.
725      ELSE
726        def_beha = .FALSE.
727        len_str = LEN_TRIM(str_READ)
728        io_err = 0
729        SELECT CASE (k_typ)
730        CASE(k_i)
731          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
732          READ (UNIT=str_READ(1:len_str), &
733 &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
734        CASE(k_r)
735          READ (UNIT=str_READ(1:len_str), &
736 &              FMT=*,IOSTAT=io_err) r_val(it)
737        CASE(k_c)
738          c_val(it) = str_READ(1:len_str)
739        CASE(k_l)
740          ipos_tr = -1
741          ipos_fl = -1
742          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
743 &                      INDEX(str_READ_lower,'y'))
744          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
745 &                      INDEX(str_READ_lower,'n'))
746          IF (ipos_tr > 0) THEN
747            l_val(it) = .TRUE.
748          ELSE IF (ipos_fl > 0) THEN
749            l_val(it) = .FALSE.
750          ELSE
751            io_err = 100
752          ENDIF
753        END SELECT
754        IF (io_err /= 0) THEN
755          CALL ipslerr (3,'get_fil', &
756 &         'Target '//TRIM(target), &
757 &         'is not of '//TRIM(c_vtyp)//' type',' ')
758        ENDIF
759      ENDIF
760!-----
761      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
762!-------
763!------ Is this the value of a compressed field ?
764        compressed = (compline(pos) > 0)
765        IF (compressed) THEN
766          IF (compline(pos) /= nb_to_ret) THEN
767            CALL ipslerr (2,'get_fil', &
768 &           'For key '//TRIM(target)//' we have a compressed field', &
769 &           'which does not have the right size.', &
770 &           'We will try to fix that.')
771          ENDIF
772          IF      (k_typ == k_i) THEN
773            i_cmpval = i_val(it)
774          ELSE IF (k_typ == k_r) THEN
775            r_cmpval = r_val(it)
776          ENDIF
777        ENDIF
778      ENDIF
779    ELSE
780      found(it) = .FALSE.
781      def_beha = .FALSE.
782      compressed = .FALSE.
783    ENDIF
784  ENDDO
785!-
786  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
787!---
788!-- If this is a compressed field then we will uncompress it
789    IF (compressed) THEN
790      DO it=1,nb_to_ret
791        IF (.NOT.found(it)) THEN
792          IF      (k_typ == k_i) THEN
793            i_val(it) = i_cmpval
794          ELSE IF (k_typ == k_r) THEN
795          ENDIF
796          found(it) = .TRUE.
797        ENDIF
798      ENDDO
799    ENDIF
800  ENDIF
801!-
802! Now we set the status for what we found
803  IF (def_beha) THEN
804    status = 2
805    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
806  ELSE
807    status_cnt = 0
808    DO it=1,nb_to_ret
809      IF (.NOT.found(it)) THEN
810        status_cnt = status_cnt+1
811        IF      (status_cnt <= max_msgs) THEN
812          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
813 &               ADVANCE='NO') TRIM(target)
814          IF (nb_to_ret > 1) THEN
815            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
816            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
817          ENDIF
818          SELECT CASE (k_typ)
819          CASE(k_i)
820            WRITE (UNIT=*,FMT=*) "=",i_val(it)
821          CASE(k_r)
822            WRITE (UNIT=*,FMT=*) "=",r_val(it)
823          CASE(k_c)
824            WRITE (UNIT=*,FMT=*) "=",c_val(it)
825          CASE(k_l)
826            WRITE (UNIT=*,FMT=*) "=",l_val(it)
827          END SELECT
828        ELSE IF (status_cnt == max_msgs+1) THEN
829          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
830        ENDIF
831      ENDIF
832    ENDDO
833!---
834    IF (status_cnt == 0) THEN
835      status = 1
836    ELSE IF (status_cnt == nb_to_ret) THEN
837      status = 2
838    ELSE
839      status = 3
840    ENDIF
841  ENDIF
842! Deallocate the memory
843  DEALLOCATE(found)
844!---------------------
845END SUBROUTINE get_fil
846!===
847SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
848!---------------------------------------------------------------------
849!- Read the required variable in the database
850!---------------------------------------------------------------------
851  IMPLICIT NONE
852!-
853  INTEGER :: pos,size_of_in
854  CHARACTER(LEN=*) :: target
855  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
856  REAL,DIMENSION(:),OPTIONAL             :: r_val
857  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
858  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
859!-
860  INTEGER :: k_typ,k_beg,k_end
861  CHARACTER(LEN=9) :: c_vtyp
862!---------------------------------------------------------------------
863!-
864! Get the type of the argument
865  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
866  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
867 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
868    CALL ipslerr (3,'get_rdb', &
869 &   'Internal error','Unknown type of data',' ')
870  ENDIF
871!-
872  IF (key_tab(pos)%keytype /= k_typ) THEN
873    CALL ipslerr (3,'get_rdb', &
874 &   'Wrong data type for keyword '//TRIM(target), &
875 &   '(NOT '//TRIM(c_vtyp)//')',' ')
876  ENDIF
877!-
878  IF (key_tab(pos)%keycompress > 0) THEN
879    IF (    (key_tab(pos)%keycompress /= size_of_in) &
880 &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
881      CALL ipslerr (3,'get_rdb', &
882 &     'Wrong compression length','for keyword '//TRIM(target),' ')
883    ELSE
884      SELECT CASE (k_typ)
885      CASE(k_i)
886        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
887      CASE(k_r)
888        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
889      END SELECT
890    ENDIF
891  ELSE
892    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
893      CALL ipslerr (3,'get_rdb', &
894 &     'Wrong array length','for keyword '//TRIM(target),' ')
895    ELSE
896      k_beg = key_tab(pos)%keymemstart
897      k_end = k_beg+key_tab(pos)%keymemlen-1
898      SELECT CASE (k_typ)
899      CASE(k_i)
900        i_val(1:size_of_in) = i_mem(k_beg:k_end)
901      CASE(k_r)
902        r_val(1:size_of_in) = r_mem(k_beg:k_end)
903      CASE(k_c)
904        c_val(1:size_of_in) = c_mem(k_beg:k_end)
905      CASE(k_l)
906        l_val(1:size_of_in) = l_mem(k_beg:k_end)
907      END SELECT
908    ENDIF
909  ENDIF
910!---------------------
911END SUBROUTINE get_rdb
912!===
913SUBROUTINE get_wdb &
914 &  (target,status,fileorig,size_of_in, &
915 &   i_val,r_val,c_val,l_val)
916!---------------------------------------------------------------------
917!- Write data into the data base
918!---------------------------------------------------------------------
919  IMPLICIT NONE
920!-
921  CHARACTER(LEN=*) :: target
922  INTEGER :: status,fileorig,size_of_in
923  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
924  REAL,DIMENSION(:),OPTIONAL             :: r_val
925  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
926  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
927!-
928  INTEGER :: k_typ
929  CHARACTER(LEN=9) :: c_vtyp
930  INTEGER :: k_mempos,k_memsize,k_beg,k_end
931  LOGICAL :: l_cmp
932!---------------------------------------------------------------------
933!-
934! Get the type of the argument
935  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
936  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
937 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
938    CALL ipslerr (3,'get_wdb', &
939 &   'Internal error','Unknown type of data',' ')
940  ENDIF
941!-
942! First check if we have sufficiant space for the new key
943  IF (nb_keys+1 > keymemsize) THEN
944    CALL getin_allockeys ()
945  ENDIF
946!-
947  SELECT CASE (k_typ)
948  CASE(k_i)
949    k_mempos = i_mempos; k_memsize = i_memsize;
950    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
951 &         .AND.(size_of_in > compress_lim)
952  CASE(k_r)
953    k_mempos = r_mempos; k_memsize = r_memsize;
954    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
955 &         .AND.(size_of_in > compress_lim)
956  CASE(k_c)
957    k_mempos = c_mempos; k_memsize = c_memsize;
958    l_cmp = .FALSE.
959  CASE(k_l)
960    k_mempos = l_mempos; k_memsize = l_memsize;
961    l_cmp = .FALSE.
962  END SELECT
963!-
964! Fill out the items of the data base
965  nb_keys = nb_keys+1
966  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
967  key_tab(nb_keys)%keystatus = status
968  key_tab(nb_keys)%keytype = k_typ
969  key_tab(nb_keys)%keyfromfile = fileorig
970  key_tab(nb_keys)%keymemstart = k_mempos+1
971  IF (l_cmp) THEN
972    key_tab(nb_keys)%keycompress = size_of_in
973    key_tab(nb_keys)%keymemlen = 1
974  ELSE
975    key_tab(nb_keys)%keycompress = -1
976    key_tab(nb_keys)%keymemlen = size_of_in
977  ENDIF
978!-
979! Before writing the actual size lets see if we have the space
980  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
981 &    > k_memsize) THEN
982    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
983  ENDIF
984!-
985  k_beg = key_tab(nb_keys)%keymemstart
986  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
987  SELECT CASE (k_typ)
988  CASE(k_i)
989    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
990    i_mempos = k_end
991  CASE(k_r)
992    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
993    r_mempos = k_end
994  CASE(k_c)
995    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
996    c_mempos = k_end
997  CASE(k_l)
998    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
999    l_mempos = k_end
1000  END SELECT
1001!---------------------
1002END SUBROUTINE get_wdb
1003!-
1004!===
1005!-
1006SUBROUTINE getin_read
1007!---------------------------------------------------------------------
1008  IMPLICIT NONE
1009!-
1010  INTEGER,SAVE :: allread=0
1011  INTEGER,SAVE :: current
1012!---------------------------------------------------------------------
1013  IF (allread == 0) THEN
1014!-- Allocate a first set of memory.
1015    CALL getin_alloctxt ()
1016    CALL getin_allockeys ()
1017    CALL getin_allocmem (k_i,0)
1018    CALL getin_allocmem (k_r,0)
1019    CALL getin_allocmem (k_c,0)
1020    CALL getin_allocmem (k_l,0)
1021!-- Start with reading the files
1022    nbfiles = 1
1023    filelist(1) = 'run.def'
1024    current = 1
1025!--
1026    DO WHILE (current <= nbfiles)
1027      CALL getin_readdef (current)
1028      current = current+1
1029    ENDDO
1030    allread = 1
1031    CALL getin_checkcohe ()
1032  ENDIF
1033!------------------------
1034END SUBROUTINE getin_read
1035!-
1036!===
1037!-
1038  SUBROUTINE getin_readdef(current)
1039!---------------------------------------------------------------------
1040!- This subroutine will read the files and only keep the
1041!- the relevant information. The information is kept as it
1042!- found in the file. The data will be analysed later.
1043!---------------------------------------------------------------------
1044  IMPLICIT NONE
1045!-
1046  INTEGER :: current
1047!-
1048  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
1049  CHARACTER(LEN=n_d_fmt) :: cnt
1050  CHARACTER(LEN=10) :: c_fmt
1051  INTEGER :: nb_lastkey
1052!-
1053  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
1054  LOGICAL :: check = .FALSE.
1055!---------------------------------------------------------------------
1056  eof = 0
1057  ptn = 1
1058  nb_lastkey = 0
1059!-
1060  IF (check) THEN
1061    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
1062  ENDIF
1063!-
1064  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
1065  IF (io_err /= 0) THEN
1066    CALL ipslerr (2,'getin_readdef', &
1067 &  'Could not open file '//TRIM(filelist(current)),' ',' ')
1068    RETURN
1069  ENDIF
1070!-
1071  DO WHILE (eof /= 1)
1072!---
1073    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
1074    len_str = LEN_TRIM(READ_str)
1075    ptn = INDEX(READ_str,'=')
1076!---
1077    IF (ptn > 0) THEN
1078!---- Get the target
1079      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
1080!---- Make sure that a vector keyword has the right length
1081      iund = INDEX(key_str,'__')
1082      IF (iund > 0) THEN
1083        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
1084 &        LEN_TRIM(key_str)-iund-1
1085        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
1086 &           FMT=c_fmt,IOSTAT=io_err) it
1087        IF ( (io_err == 0).AND.(it > 0) ) THEN
1088          WRITE(UNIT=cnt,FMT=c_i_fmt) it
1089          key_str = key_str(1:iund+1)//cnt
1090        ELSE
1091          CALL ipslerr (3,'getin_readdef', &
1092 &         'A very strange key has just been found :', &
1093 &         TRIM(key_str),' ')
1094        ENDIF
1095      ENDIF
1096!---- Prepare the content
1097      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
1098      CALL nocomma (NEW_str)
1099      CALL cmpblank (NEW_str)
1100      NEW_str  = TRIM(ADJUSTL(NEW_str))
1101      IF (check) THEN
1102        WRITE(*,*) &
1103 &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
1104      ENDIF
1105!---- Decypher the content of NEW_str
1106!-
1107!---- This has to be a new key word, thus :
1108      nb_lastkey = 0
1109!----
1110      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1111!----
1112    ELSE IF (len_str > 0) THEN
1113!---- Prepare the key if we have an old one to which
1114!---- we will add the line just read
1115      IF (nb_lastkey > 0) THEN
1116        iund =  INDEX(last_key,'__')
1117        IF (iund > 0) THEN
1118!-------- We only continue a keyword, thus it is easy
1119          key_str = last_key(1:iund-1)
1120        ELSE
1121          IF (nb_lastkey /= 1) THEN
1122            CALL ipslerr (3,'getin_readdef', &
1123 &           'We can not have a scalar keyword', &
1124 &           'and a vector content',' ')
1125          ENDIF
1126!-------- The last keyword needs to be transformed into a vector.
1127          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
1128          targetlist(nb_lines) = &
1129 &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
1130          key_str = last_key(1:LEN_TRIM(last_key))
1131        ENDIF
1132      ENDIF
1133!---- Prepare the content
1134      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
1135      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1136    ELSE
1137!---- If we have an empty line then the keyword finishes
1138      nb_lastkey = 0
1139      IF (check) THEN
1140        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
1141      ENDIF
1142    ENDIF
1143  ENDDO
1144!-
1145  CLOSE(UNIT=22)
1146!-
1147  IF (check) THEN
1148    OPEN (UNIT=22,file='run.def.test')
1149    DO i=1,nb_lines
1150      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
1151    ENDDO
1152    CLOSE(UNIT=22)
1153  ENDIF
1154!---------------------------
1155END SUBROUTINE getin_readdef
1156!-
1157!===
1158!-
1159SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
1160!---------------------------------------------------------------------
1161!- This subroutine is going to decypher the line.
1162!- It essentialy checks how many items are included and
1163!- it they can be attached to a key.
1164!---------------------------------------------------------------------
1165  IMPLICIT NONE
1166!-
1167! ARGUMENTS
1168!-
1169  INTEGER :: current,nb_lastkey
1170  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
1171!-
1172! LOCAL
1173!-
1174  INTEGER :: len_str,blk,nbve,starpos
1175  CHARACTER(LEN=100) :: tmp_str,new_key,mult
1176  CHARACTER(LEN=n_d_fmt) :: cnt
1177  CHARACTER(LEN=10) :: c_fmt
1178!---------------------------------------------------------------------
1179  len_str = LEN_TRIM(NEW_str)
1180  blk = INDEX(NEW_str(1:len_str),' ')
1181  tmp_str = NEW_str(1:len_str)
1182!-
1183! If the key is a new file then we take it up. Else
1184! we save the line and go on.
1185!-
1186  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
1187    DO WHILE (blk > 0)
1188      IF (nbfiles+1 > max_files) THEN
1189        CALL ipslerr (3,'getin_decrypt', &
1190 &       'Too many files to include',' ',' ')
1191      ENDIF
1192!-----
1193      nbfiles = nbfiles+1
1194      filelist(nbfiles) = tmp_str(1:blk)
1195!-----
1196      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1197      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
1198    ENDDO
1199!---
1200    IF (nbfiles+1 > max_files) THEN
1201      CALL ipslerr (3,'getin_decrypt', &
1202 &     'Too many files to include',' ',' ')
1203    ENDIF
1204!---
1205    nbfiles =  nbfiles+1
1206    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
1207!---
1208    last_key = 'INCLUDEDEF'
1209    nb_lastkey = 1
1210  ELSE
1211!-
1212!-- We are working on a new line of input
1213!-
1214    IF (nb_lines+1 > i_txtsize) THEN
1215      CALL getin_alloctxt ()
1216    ENDIF
1217    nb_lines = nb_lines+1
1218!-
1219!-- First we solve the issue of conpressed information. Once
1220!-- this is done all line can be handled in the same way.
1221!-
1222    starpos = INDEX(NEW_str(1:len_str),'*')
1223    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
1224 &                    .AND.(tmp_str(1:1) /= "'") ) THEN
1225!-----
1226      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
1227        CALL ipslerr (3,'getin_decrypt', &
1228 &       'We can not have a compressed field of values', &
1229 &       'in a vector notation (TARGET__n).', &
1230 &       'The key at fault : '//TRIM(key_str))
1231      ENDIF
1232!-
1233!---- Read the multiplied
1234!-
1235      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
1236!---- Construct the new string and its parameters
1237      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
1238      len_str = LEN_TRIM(NEW_str)
1239      blk = INDEX(NEW_str(1:len_str),' ')
1240      IF (blk > 1) THEN
1241        CALL ipslerr (2,'getin_decrypt', &
1242 &       'This is a strange behavior','you could report',' ')
1243      ENDIF
1244      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
1245      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
1246!---
1247    ELSE
1248      compline(nb_lines) = -1
1249    ENDIF
1250!-
1251!-- If there is no space wthin the line then the target is a scalar
1252!-- or the element of a properly written vector.
1253!-- (ie of the type TARGET__00001)
1254!-
1255    IF (    (blk <= 1) &
1256 &      .OR.(tmp_str(1:1) == '"') &
1257 &      .OR.(tmp_str(1:1) == "'") ) THEN
1258!-
1259      IF (nb_lastkey == 0) THEN
1260!------ Save info of current keyword as a scalar
1261!------ if it is not a continuation
1262        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1263        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
1264        nb_lastkey = 1
1265      ELSE
1266!------ We are continuing a vector so the keyword needs
1267!------ to get the underscores
1268        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
1269        targetlist(nb_lines) = &
1270 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1271        last_key = &
1272 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1273        nb_lastkey = nb_lastkey+1
1274      ENDIF
1275!-----
1276      fichier(nb_lines) = NEW_str(1:len_str)
1277      fromfile(nb_lines) = current
1278    ELSE
1279!-
1280!---- If there are blanks whithin the line then we are dealing
1281!---- with a vector and we need to split it in many entries
1282!---- with the TARGET__n notation.
1283!----
1284!---- Test if the targer is not already a vector target !
1285!-
1286      IF (INDEX(TRIM(key_str),'__') > 0) THEN
1287        CALL ipslerr (3,'getin_decrypt', &
1288 &       'We have found a mixed vector notation (TARGET__n).', &
1289 &       'The key at fault : '//TRIM(key_str),' ')
1290      ENDIF
1291!-
1292      nbve = nb_lastkey
1293      nbve = nbve+1
1294      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1295!-
1296      DO WHILE (blk > 0)
1297!-
1298!------ Save the content of target__nbve
1299!-
1300        fichier(nb_lines) = tmp_str(1:blk)
1301        new_key = &
1302 &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1303        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1304        fromfile(nb_lines) = current
1305!-
1306        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1307        blk = INDEX(TRIM(tmp_str),' ')
1308!-
1309        IF (nb_lines+1 > i_txtsize) THEN
1310          CALL getin_alloctxt ()
1311        ENDIF
1312        nb_lines = nb_lines+1
1313        nbve = nbve+1
1314        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
1315!-
1316      ENDDO
1317!-
1318!---- Save the content of the last target
1319!-
1320      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
1321      new_key = &
1322 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1323      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
1324      fromfile(nb_lines) = current
1325!-
1326      last_key = &
1327 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
1328      nb_lastkey = nbve
1329!-
1330    ENDIF
1331!-
1332  ENDIF
1333!---------------------------
1334END SUBROUTINE getin_decrypt
1335!-
1336!===
1337!-
1338SUBROUTINE getin_checkcohe ()
1339!---------------------------------------------------------------------
1340!- This subroutine checks for redundancies.
1341!---------------------------------------------------------------------
1342  IMPLICIT NONE
1343!-
1344  INTEGER :: line,n_k,k
1345!---------------------------------------------------------------------
1346  DO line=1,nb_lines-1
1347!-
1348    n_k = 0
1349    DO k=line+1,nb_lines
1350      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
1351        n_k = k
1352        EXIT
1353      ENDIF
1354    ENDDO
1355!---
1356!-- IF we have found it we have a problem to solve.
1357!---
1358    IF (n_k > 0) THEN
1359      WRITE(*,*) 'COUNT : ',n_k
1360      WRITE(*,*) &
1361 &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
1362      WRITE(*,*) &
1363 &  'getin_checkcohe : The following values were encoutered :'
1364      WRITE(*,*) &
1365 &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
1366      WRITE(*,*) &
1367 &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
1368      WRITE(*,*) &
1369 &  'getin_checkcohe : We will keep only the last value'
1370      targetlist(line) = ' '
1371    ENDIF
1372  ENDDO
1373!-----------------------------
1374END SUBROUTINE getin_checkcohe
1375!-
1376!===
1377!-
1378SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
1379!---------------------------------------------------------------------
1380  IMPLICIT NONE
1381!-
1382  INTEGER :: unit,eof,nb_lastkey
1383  CHARACTER(LEN=100) :: dummy
1384  CHARACTER(LEN=100) :: out_string
1385  CHARACTER(LEN=1) :: first
1386!---------------------------------------------------------------------
1387  first="#"
1388  eof = 0
1389  out_string = "    "
1390!-
1391  DO WHILE (first == "#")
1392    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
1393    dummy = TRIM(ADJUSTL(dummy))
1394    first=dummy(1:1)
1395    IF (first == "#") THEN
1396      nb_lastkey = 0
1397    ENDIF
1398  ENDDO
1399  out_string=dummy
1400!-
1401  RETURN
1402!-
14039998 CONTINUE
1404  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
1405!-
14067778 CONTINUE
1407  eof = 1
1408!----------------------------
1409END SUBROUTINE getin_skipafew
1410!-
1411!===
1412!-
1413SUBROUTINE getin_allockeys ()
1414!---------------------------------------------------------------------
1415  IMPLICIT NONE
1416!-
1417  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
1418  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
1419!-
1420  INTEGER :: ier
1421  CHARACTER(LEN=20) :: c_tmp
1422!---------------------------------------------------------------------
1423  IF (keymemsize == 0) THEN
1424!---
1425!-- Nothing exists in memory arrays and it is easy to do.
1426!---
1427    WRITE (UNIT=c_tmp,FMT=*) memslabs
1428    ALLOCATE(key_tab(memslabs),stat=ier)
1429    IF (ier /= 0) THEN
1430      CALL ipslerr (3,'getin_allockeys', &
1431 &     'Can not allocate key_tab', &
1432 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1433    ENDIF
1434    nb_keys = 0
1435    keymemsize = memslabs
1436    key_tab(:)%keycompress = -1
1437!---
1438  ELSE
1439!---
1440!-- There is something already in the memory,
1441!-- we need to transfer and reallocate.
1442!---
1443    WRITE (UNIT=c_tmp,FMT=*) keymemsize
1444    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
1445    IF (ier /= 0) THEN
1446      CALL ipslerr (3,'getin_allockeys', &
1447 &     'Can not allocate tmp_key_tab', &
1448 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1449    ENDIF
1450    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
1451    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
1452    DEALLOCATE(key_tab)
1453    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
1454    IF (ier /= 0) THEN
1455      CALL ipslerr (3,'getin_allockeys', &
1456 &     'Can not allocate key_tab', &
1457 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1458    ENDIF
1459    key_tab(:)%keycompress = -1
1460    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
1461    DEALLOCATE(tmp_key_tab)
1462    keymemsize = keymemsize+memslabs
1463  ENDIF
1464!-----------------------------
1465END SUBROUTINE getin_allockeys
1466!-
1467!===
1468!-
1469SUBROUTINE getin_allocmem (type,len_wanted)
1470!---------------------------------------------------------------------
1471!- Allocate the memory of the data base for all 4 types of memory
1472!- INTEGER / REAL / CHARACTER / LOGICAL
1473!---------------------------------------------------------------------
1474  IMPLICIT NONE
1475!-
1476  INTEGER :: type,len_wanted
1477!-
1478  INTEGER,ALLOCATABLE :: tmp_int(:)
1479  REAL,ALLOCATABLE :: tmp_real(:)
1480  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
1481  LOGICAL,ALLOCATABLE :: tmp_logic(:)
1482  INTEGER :: ier
1483  CHARACTER(LEN=20) :: c_tmp
1484!---------------------------------------------------------------------
1485  SELECT CASE (type)
1486  CASE(k_i)
1487    IF (i_memsize == 0) THEN
1488      ALLOCATE(i_mem(memslabs),stat=ier)
1489      IF (ier /= 0) THEN
1490        WRITE (UNIT=c_tmp,FMT=*) memslabs
1491        CALL ipslerr (3,'getin_allocmem', &
1492 &       'Unable to allocate db-memory', &
1493 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1494      ENDIF
1495      i_memsize=memslabs
1496    ELSE
1497      ALLOCATE(tmp_int(i_memsize),stat=ier)
1498      IF (ier /= 0) THEN
1499        WRITE (UNIT=c_tmp,FMT=*) i_memsize
1500        CALL ipslerr (3,'getin_allocmem', &
1501 &       'Unable to allocate tmp_int', &
1502 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1503      ENDIF
1504      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
1505      DEALLOCATE(i_mem)
1506      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
1507      IF (ier /= 0) THEN
1508        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
1509        CALL ipslerr (3,'getin_allocmem', &
1510 &       'Unable to re-allocate db-memory', &
1511 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1512      ENDIF
1513      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
1514      i_memsize = i_memsize+MAX(memslabs,len_wanted)
1515      DEALLOCATE(tmp_int)
1516    ENDIF
1517  CASE(k_r)
1518    IF (r_memsize == 0) THEN
1519      ALLOCATE(r_mem(memslabs),stat=ier)
1520      IF (ier /= 0) THEN
1521        WRITE (UNIT=c_tmp,FMT=*) memslabs
1522        CALL ipslerr (3,'getin_allocmem', &
1523 &       'Unable to allocate db-memory', &
1524 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1525      ENDIF
1526      r_memsize =  memslabs
1527    ELSE
1528      ALLOCATE(tmp_real(r_memsize),stat=ier)
1529      IF (ier /= 0) THEN
1530        WRITE (UNIT=c_tmp,FMT=*) r_memsize
1531        CALL ipslerr (3,'getin_allocmem', &
1532 &       'Unable to allocate tmp_real', &
1533 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1534      ENDIF
1535      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
1536      DEALLOCATE(r_mem)
1537      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
1538      IF (ier /= 0) THEN
1539        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
1540        CALL ipslerr (3,'getin_allocmem', &
1541 &       'Unable to re-allocate db-memory', &
1542 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1543      ENDIF
1544      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
1545      r_memsize = r_memsize+MAX(memslabs,len_wanted)
1546      DEALLOCATE(tmp_real)
1547    ENDIF
1548  CASE(k_c)
1549    IF (c_memsize == 0) THEN
1550      ALLOCATE(c_mem(memslabs),stat=ier)
1551      IF (ier /= 0) THEN
1552        WRITE (UNIT=c_tmp,FMT=*) memslabs
1553        CALL ipslerr (3,'getin_allocmem', &
1554 &       'Unable to allocate db-memory', &
1555 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1556      ENDIF
1557      c_memsize = memslabs
1558    ELSE
1559      ALLOCATE(tmp_char(c_memsize),stat=ier)
1560      IF (ier /= 0) THEN
1561        WRITE (UNIT=c_tmp,FMT=*) c_memsize
1562        CALL ipslerr (3,'getin_allocmem', &
1563 &       'Unable to allocate tmp_char', &
1564 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1565      ENDIF
1566      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
1567      DEALLOCATE(c_mem)
1568      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
1569      IF (ier /= 0) THEN
1570        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
1571        CALL ipslerr (3,'getin_allocmem', &
1572 &       'Unable to re-allocate db-memory', &
1573 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1574      ENDIF
1575      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
1576      c_memsize = c_memsize+MAX(memslabs,len_wanted)
1577      DEALLOCATE(tmp_char)
1578    ENDIF
1579  CASE(k_l)
1580    IF (l_memsize == 0) THEN
1581      ALLOCATE(l_mem(memslabs),stat=ier)
1582      IF (ier /= 0) THEN
1583        WRITE (UNIT=c_tmp,FMT=*) memslabs
1584        CALL ipslerr (3,'getin_allocmem', &
1585 &       'Unable to allocate db-memory', &
1586 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1587      ENDIF
1588      l_memsize = memslabs
1589    ELSE
1590      ALLOCATE(tmp_logic(l_memsize),stat=ier)
1591      IF (ier /= 0) THEN
1592        WRITE (UNIT=c_tmp,FMT=*) l_memsize
1593        CALL ipslerr (3,'getin_allocmem', &
1594 &       'Unable to allocate tmp_logic', &
1595 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
1596      ENDIF
1597      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
1598      DEALLOCATE(l_mem)
1599      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
1600      IF (ier /= 0) THEN
1601        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
1602        CALL ipslerr (3,'getin_allocmem', &
1603 &       'Unable to re-allocate db-memory', &
1604 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
1605      ENDIF
1606      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
1607      l_memsize = l_memsize+MAX(memslabs,len_wanted)
1608      DEALLOCATE(tmp_logic)
1609    ENDIF
1610  CASE DEFAULT
1611    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
1612  END SELECT
1613!----------------------------
1614END SUBROUTINE getin_allocmem
1615!-
1616!===
1617!-
1618SUBROUTINE getin_alloctxt ()
1619!---------------------------------------------------------------------
1620  IMPLICIT NONE
1621!-
1622  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
1623  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
1624  INTEGER,ALLOCATABLE :: tmp_int(:)
1625!-
1626  INTEGER :: ier
1627  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
1628!---------------------------------------------------------------------
1629  IF (i_txtsize == 0) THEN
1630!---
1631!-- Nothing exists in memory arrays and it is easy to do.
1632!---
1633    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
1634    ALLOCATE(fichier(i_txtslab),stat=ier)
1635    IF (ier /= 0) THEN
1636      CALL ipslerr (3,'getin_alloctxt', &
1637 &     'Can not allocate fichier', &
1638 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1639    ENDIF
1640!---
1641    ALLOCATE(targetlist(i_txtslab),stat=ier)
1642    IF (ier /= 0) THEN
1643      CALL ipslerr (3,'getin_alloctxt', &
1644 &     'Can not allocate targetlist', &
1645 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1646    ENDIF
1647!---
1648    ALLOCATE(fromfile(i_txtslab),stat=ier)
1649    IF (ier /= 0) THEN
1650      CALL ipslerr (3,'getin_alloctxt', &
1651 &     'Can not allocate fromfile', &
1652 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1653    ENDIF
1654!---
1655    ALLOCATE(compline(i_txtslab),stat=ier)
1656    IF (ier /= 0) THEN
1657      CALL ipslerr (3,'getin_alloctxt', &
1658 &     'Can not allocate compline', &
1659 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1660    ENDIF
1661!---
1662    nb_lines = 0
1663    i_txtsize = i_txtslab
1664  ELSE
1665!---
1666!-- There is something already in the memory,
1667!-- we need to transfer and reallocate.
1668!---
1669    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
1670    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
1671    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
1672    IF (ier /= 0) THEN
1673      CALL ipslerr (3,'getin_alloctxt', &
1674 &     'Can not allocate tmp_fic', &
1675 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1676    ENDIF
1677    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
1678    DEALLOCATE(fichier)
1679    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
1680    IF (ier /= 0) THEN
1681      CALL ipslerr (3,'getin_alloctxt', &
1682 &     'Can not allocate fichier', &
1683 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1684    ENDIF
1685    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
1686    DEALLOCATE(tmp_fic)
1687!---
1688    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
1689    IF (ier /= 0) THEN
1690      CALL ipslerr (3,'getin_alloctxt', &
1691 &     'Can not allocate tmp_tgl', &
1692 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1693    ENDIF
1694    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
1695    DEALLOCATE(targetlist)
1696    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
1697    IF (ier /= 0) THEN
1698      CALL ipslerr (3,'getin_alloctxt', &
1699 &     'Can not allocate targetlist', &
1700 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1701    ENDIF
1702    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
1703    DEALLOCATE(tmp_tgl)
1704!---
1705    ALLOCATE(tmp_int(i_txtsize),stat=ier)
1706    IF (ier /= 0) THEN
1707      CALL ipslerr (3,'getin_alloctxt', &
1708 &     'Can not allocate tmp_int', &
1709 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
1710    ENDIF
1711    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
1712    DEALLOCATE(fromfile)
1713    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
1714    IF (ier /= 0) THEN
1715      CALL ipslerr (3,'getin_alloctxt', &
1716 &     'Can not allocate fromfile', &
1717 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1718    ENDIF
1719    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
1720!---
1721    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
1722    DEALLOCATE(compline)
1723    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
1724    IF (ier /= 0) THEN
1725      CALL ipslerr (3,'getin_alloctxt', &
1726 &     'Can not allocate compline', &
1727 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
1728    ENDIF
1729    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
1730    DEALLOCATE(tmp_int)
1731!---
1732    i_txtsize = i_txtsize+i_txtslab
1733  ENDIF
1734!----------------------------
1735END SUBROUTINE getin_alloctxt
1736!-
1737!===
1738!-
1739SUBROUTINE getin_dump (fileprefix)
1740!---------------------------------------------------------------------
1741  IMPLICIT NONE
1742!-
1743  CHARACTER(*),OPTIONAL :: fileprefix
1744!-
1745  CHARACTER(LEN=80) :: usedfileprefix
1746  INTEGER :: ikey,if,iff,iv
1747  CHARACTER(LEN=20) :: c_tmp
1748  CHARACTER(LEN=100) :: tmp_str,used_filename
1749  LOGICAL :: check = .FALSE.
1750!---------------------------------------------------------------------
1751  IF (PRESENT(fileprefix)) THEN
1752    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
1753  ELSE
1754    usedfileprefix = "used"
1755  ENDIF
1756!-
1757  DO if=1,nbfiles
1758!---
1759    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
1760    IF (check) THEN
1761      WRITE(*,*) &
1762 &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
1763      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
1764    ENDIF
1765    OPEN (UNIT=22,FILE=used_filename)
1766!---
1767!-- If this is the first file we need to add the list
1768!-- of file which belong to it
1769    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
1770      WRITE(22,*) '# '
1771      WRITE(22,*) '# This file is linked to the following files :'
1772      WRITE(22,*) '# '
1773      DO iff=2,nbfiles
1774        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
1775      ENDDO
1776      WRITE(22,*) '# '
1777    ENDIF
1778!---
1779    DO ikey=1,nb_keys
1780!-----
1781!---- Is this key from this file ?
1782      IF (key_tab(ikey)%keyfromfile == if) THEN
1783!-------
1784!------ Write some comments
1785        WRITE(22,*) '#'
1786        SELECT CASE (key_tab(ikey)%keystatus)
1787        CASE(1)
1788          WRITE(22,*) '# Values of ', &
1789 &          TRIM(key_tab(ikey)%keystr),' comes from the run.def.'
1790        CASE(2)
1791          WRITE(22,*) '# Values of ', &
1792 &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
1793        CASE(3)
1794          WRITE(22,*) '# Values of ', &
1795 &          TRIM(key_tab(ikey)%keystr), &
1796 &          ' are a mix of run.def and defaults.'
1797        CASE DEFAULT
1798          WRITE(22,*) '# Dont know from where the value of ', &
1799 &          TRIM(key_tab(ikey)%keystr),' comes.'
1800        END SELECT
1801        WRITE(22,*) '#'
1802!-------
1803!------ Write the values
1804        SELECT CASE (key_tab(ikey)%keytype)
1805        CASE(k_i)
1806          IF (key_tab(ikey)%keymemlen == 1) THEN
1807            IF (key_tab(ikey)%keycompress < 0) THEN
1808              WRITE(22,*) &
1809 &              TRIM(key_tab(ikey)%keystr), &
1810 &              ' = ',i_mem(key_tab(ikey)%keymemstart)
1811            ELSE
1812              WRITE(22,*) &
1813 &              TRIM(key_tab(ikey)%keystr), &
1814 &              ' = ',key_tab(ikey)%keycompress, &
1815 &              ' * ',i_mem(key_tab(ikey)%keymemstart)
1816            ENDIF
1817          ELSE
1818            DO iv=0,key_tab(ikey)%keymemlen-1
1819              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1820              WRITE(22,*) &
1821 &              TRIM(key_tab(ikey)%keystr), &
1822 &              '__',TRIM(ADJUSTL(c_tmp)), &
1823 &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
1824            ENDDO
1825          ENDIF
1826        CASE(k_r)
1827          IF (key_tab(ikey)%keymemlen == 1) THEN
1828            IF (key_tab(ikey)%keycompress < 0) THEN
1829              WRITE(22,*) &
1830 &              TRIM(key_tab(ikey)%keystr), &
1831 &              ' = ',r_mem(key_tab(ikey)%keymemstart)
1832            ELSE
1833              WRITE(22,*) &
1834 &              TRIM(key_tab(ikey)%keystr), &
1835 &              ' = ',key_tab(ikey)%keycompress, &
1836                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
1837            ENDIF
1838          ELSE
1839            DO iv=0,key_tab(ikey)%keymemlen-1
1840              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1841              WRITE(22,*) &
1842 &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
1843 &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
1844            ENDDO
1845          ENDIF
1846        CASE(k_c)
1847          IF (key_tab(ikey)%keymemlen == 1) THEN
1848            tmp_str = c_mem(key_tab(ikey)%keymemstart)
1849            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
1850 &              ' = ',TRIM(tmp_str)
1851          ELSE
1852            DO iv=0,key_tab(ikey)%keymemlen-1
1853              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1854              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
1855              WRITE(22,*) &
1856 &              TRIM(key_tab(ikey)%keystr), &
1857 &              '__',TRIM(ADJUSTL(c_tmp)), &
1858 &              ' = ',TRIM(tmp_str)
1859            ENDDO
1860          ENDIF
1861        CASE(k_l)
1862          IF (key_tab(ikey)%keymemlen == 1) THEN
1863            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
1864              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
1865            ELSE
1866              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
1867            ENDIF
1868          ELSE
1869            DO iv=0,key_tab(ikey)%keymemlen-1
1870              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
1871              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
1872                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1873 &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
1874              ELSE
1875                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
1876 &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
1877              ENDIF
1878            ENDDO
1879          ENDIF
1880        CASE DEFAULT
1881          CALL ipslerr (3,'getin_dump', &
1882 &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
1883 &         ' ',' ')
1884        END SELECT
1885      ENDIF
1886    ENDDO
1887!-
1888    CLOSE(UNIT=22)
1889!-
1890  ENDDO
1891!------------------------
1892END SUBROUTINE getin_dump
1893!===
1894SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
1895!---------------------------------------------------------------------
1896!- Returns the type of the argument (mutually exclusive)
1897!---------------------------------------------------------------------
1898  IMPLICIT NONE
1899!-
1900  INTEGER,INTENT(OUT) :: k_typ
1901  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
1902  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
1903  REAL,DIMENSION(:),OPTIONAL             :: r_v
1904  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
1905  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
1906!---------------------------------------------------------------------
1907  k_typ = 0
1908  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
1909 &    /= 1) THEN
1910    CALL ipslerr (3,'get_qtyp', &
1911 &   'Invalid number of optional arguments','(/= 1)',' ')
1912  ENDIF
1913!-
1914  IF     (PRESENT(i_v)) THEN
1915    k_typ = k_i
1916    c_vtyp = 'INTEGER'
1917  ELSEIF (PRESENT(r_v)) THEN
1918    k_typ = k_r
1919    c_vtyp = 'REAL'
1920  ELSEIF (PRESENT(c_v)) THEN
1921    k_typ = k_c
1922    c_vtyp = 'CHARACTER'
1923  ELSEIF (PRESENT(l_v)) THEN
1924    k_typ = k_l
1925    c_vtyp = 'LOGICAL'
1926  ENDIF
1927!----------------------
1928END SUBROUTINE get_qtyp
1929!===
1930SUBROUTINE get_findkey (i_tab,c_key,pos)
1931!---------------------------------------------------------------------
1932!- This subroutine looks for a key in a table
1933!---------------------------------------------------------------------
1934!- INPUT
1935!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
1936!-            2 -> search in targetlist(1:nb_lines)
1937!-   c_key  : Name of the key we are looking for
1938!- OUTPUT
1939!-   pos    : -1 if key not found, else value in the table
1940!---------------------------------------------------------------------
1941  IMPLICIT NONE
1942!-
1943  INTEGER,INTENT(in) :: i_tab
1944  CHARACTER(LEN=*),INTENT(in) :: c_key
1945  INTEGER,INTENT(out) :: pos
1946!-
1947  INTEGER :: ikey_max,ikey
1948  CHARACTER(LEN=l_n) :: c_q_key
1949!---------------------------------------------------------------------
1950  pos = -1
1951  IF     (i_tab == 1) THEN
1952    ikey_max = nb_keys
1953  ELSEIF (i_tab == 2) THEN
1954    ikey_max = nb_lines
1955  ELSE
1956    ikey_max = 0
1957  ENDIF
1958  IF ( ikey_max > 0 ) THEN
1959    DO ikey=1,ikey_max
1960      IF (i_tab == 1) THEN
1961        c_q_key = key_tab(ikey)%keystr
1962      ELSE
1963        c_q_key = targetlist(ikey)
1964      ENDIF
1965      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
1966        pos = ikey
1967        EXIT
1968      ENDIF
1969    ENDDO
1970  ENDIF
1971!-------------------------
1972END SUBROUTINE get_findkey
1973!===
1974!------------------
1975END MODULE getincom
Note: See TracBrowser for help on using the repository browser.