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

Last change on this file since 3279 was 3279, checked in by jgipsl, 5 years ago

Increase parameters values to be able to read longer lines from run.def. Done by Fuxing Wang, LMD

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