source: LMDZ6/trunk/libf/misc/ioipsl_getincom.F90 @ 4564

Last change on this file since 4564 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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