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

Last change on this file since 125 was 125, checked in by bellier, 17 years ago

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