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

Last change on this file since 1574 was 1574, checked in by mmaipsl, 10 years ago

Add parallel getin_dump_para function for test all non-parallel getin.

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