source: LMDZ4/trunk/libf/dyn3d/ioipsl_getincom.F90 @ 1167

Last change on this file since 1167 was 1146, checked in by Laurent Fairhead, 16 years ago

Réintegration dans le tronc des modifications issues de la branche LMDZ-dev
comprises entre la révision 1074 et 1145
Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes
résultats entre la trunk et la dev
LF
File size: 74.7 KB
Line 
1!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2! Module and routines in this file are taken from IOIPSL
3! files getincom.f90
4! Module names has been changed to avoid problems
5! if compiling model with IOIPSL library
6! Ehouarn - March 2009
7!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8MODULE ioipsl_getincom
9!---------------------------------------------------------------------
10  USE ioipsl_stringop, &
11 &   ONLY : findpos,nocomma,cmpblank,strlowercase,gensig,find_sig
12!-
13  IMPLICIT NONE
14!-
15  PRIVATE
16  PUBLIC :: getin, getin_dump
17!-
18  INTERFACE getin
19    MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
20 &                   getinis, getini1d, getini2d, &
21 &                   getincs, getinc1d, getinc2d, &
22 &                   getinls, getinl1d, getinl2d
23  END INTERFACE
24!-
25  INTEGER,PARAMETER :: max_files=100
26  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
27  INTEGER,SAVE      :: nbfiles
28!-
29  INTEGER,PARAMETER :: max_lines=4000
30  INTEGER,SAVE :: nb_lines
31  CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier
32  INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline
33  CHARACTER(LEN=30),DIMENSION(max_lines),SAVE  :: targetlist
34!-
35! The data base of parameters
36!-
37  INTEGER,PARAMETER :: memslabs=200
38  INTEGER,PARAMETER :: compress_lim = 20
39!-
40  INTEGER,SAVE :: nb_keys=0
41  INTEGER,SAVE :: keymemsize=0
42  INTEGER,SAVE,ALLOCATABLE :: keysig(:)
43  CHARACTER(LEN=30),SAVE,ALLOCATABLE :: keystr(:)
44!-
45! keystatus definition
46! keystatus = 1 : Value comes from run.def
47! keystatus = 2 : Default value is used
48! keystatus = 3 : Some vector elements were taken from default
49!-
50  INTEGER,SAVE,ALLOCATABLE :: keystatus(:)
51!-
52! keytype definition
53! keytype = 1 : Interger
54! keytype = 2 : Real
55! keytype = 3 : Character
56! keytype = 4 : Logical
57!-
58  INTEGER,SAVE,ALLOCATABLE :: keytype(:)
59!-
60! Allow compression for keys (only for integer and real)
61! keycompress < 0 : not compresses
62! keycompress > 0 : number of repeat of the value
63!-
64  INTEGER,SAVE,ALLOCATABLE :: keycompress(:)
65  INTEGER,SAVE,ALLOCATABLE :: keyfromfile(:)
66!-
67  INTEGER,SAVE,ALLOCATABLE :: keymemstart(:)
68  INTEGER,SAVE,ALLOCATABLE :: keymemlen(:)
69!-
70  INTEGER,SAVE,ALLOCATABLE :: intmem(:)
71  INTEGER,SAVE             :: intmemsize=0, intmempos=0
72  REAL,SAVE,ALLOCATABLE :: realmem(:)
73  INTEGER,SAVE          :: realmemsize=0, realmempos=0
74  CHARACTER(LEN=100),SAVE,ALLOCATABLE :: charmem(:)
75  INTEGER,SAVE             :: charmemsize=0, charmempos=0
76  LOGICAL,SAVE,ALLOCATABLE :: logicmem(:)
77  INTEGER,SAVE             :: logicmemsize=0, logicmempos=0
78!-
79CONTAINS
80!-
81!=== REAL INTERFACES
82!-
83SUBROUTINE getinrs (TARGET,ret_val)
84!---------------------------------------------------------------------
85!-  Get a real scalar. We first check if we find it
86!-  in the database and if not we get it from the run.def
87!-
88!-  getinr1d and getinr2d are written on the same pattern
89!---------------------------------------------------------------------
90  IMPLICIT NONE
91!-
92  CHARACTER(LEN=*) :: TARGET
93  REAL :: ret_val
94!-
95  REAL,DIMENSION(1) :: tmp_ret_val
96  INTEGER :: target_sig, pos, status=0, fileorig
97!---------------------------------------------------------------------
98!-
99! Compute the signature of the target
100!-
101  CALL gensig (TARGET,target_sig)
102!-
103! Do we have this target in our database ?
104!-
105  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
106!-
107  tmp_ret_val(1) = ret_val
108!-
109  IF (pos < 0) THEN
110!-- Get the information out of the file
111    CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
112!-- Put the data into the database
113    CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
114  ELSE
115!-- Get the value out of the database
116    CALL getdbrr (pos,1,TARGET,tmp_ret_val)
117  ENDIF
118  ret_val = tmp_ret_val(1)
119!---------------------
120END SUBROUTINE getinrs
121!-
122!===
123!-
124SUBROUTINE getinr1d (TARGET,ret_val)
125!---------------------------------------------------------------------
126!- See getinrs for details. It is the same thing but for a vector
127!---------------------------------------------------------------------
128  IMPLICIT NONE
129!-
130  CHARACTER(LEN=*) :: TARGET
131  REAL,DIMENSION(:) :: ret_val
132!-
133  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
134  INTEGER,SAVE :: tmp_ret_size = 0
135  INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
136!---------------------------------------------------------------------
137!-
138! Compute the signature of the target
139!-
140  CALL gensig (TARGET,target_sig)
141!-
142! Do we have this target in our database ?
143!-
144  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
145!-
146  size_of_in = SIZE(ret_val)
147  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
148    ALLOCATE (tmp_ret_val(size_of_in))
149  ELSE IF (size_of_in > tmp_ret_size) THEN
150    DEALLOCATE (tmp_ret_val)
151    ALLOCATE (tmp_ret_val(size_of_in))
152    tmp_ret_size = size_of_in
153  ENDIF
154  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
155!-
156  IF (pos < 0) THEN
157!-- Ge the information out of the file
158    CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
159!-- Put the data into the database
160    CALL getdbwr &
161 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
162  ELSE
163!-- Get the value out of the database
164    CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)
165  ENDIF
166  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
167!----------------------
168END SUBROUTINE getinr1d
169!-
170!===
171!-
172SUBROUTINE getinr2d (TARGET,ret_val)
173!---------------------------------------------------------------------
174!- See getinrs for details. It is the same thing but for a matrix
175!---------------------------------------------------------------------
176  IMPLICIT NONE
177!-
178  CHARACTER(LEN=*) :: TARGET
179  REAL,DIMENSION(:,:) :: ret_val
180!-
181  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
182  INTEGER,SAVE :: tmp_ret_size = 0
183  INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
184  INTEGER :: jl, jj, ji
185!---------------------------------------------------------------------
186!-
187! Compute the signature of the target
188!-
189  CALL gensig (TARGET,target_sig)
190!-
191! Do we have this target in our database ?
192!-
193  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
194!-
195  size_of_in = SIZE(ret_val)
196  size_1 = SIZE(ret_val,1)
197  size_2 = SIZE(ret_val,2)
198  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
199    ALLOCATE (tmp_ret_val(size_of_in))
200  ELSE IF (size_of_in > tmp_ret_size) THEN
201    DEALLOCATE (tmp_ret_val)
202    ALLOCATE (tmp_ret_val(size_of_in))
203    tmp_ret_size = size_of_in
204  ENDIF
205!-
206  jl=0
207  DO jj=1,size_2
208    DO ji=1,size_1
209      jl=jl+1
210      tmp_ret_val(jl) = ret_val(ji,jj)
211    ENDDO
212  ENDDO
213!-
214  IF (pos < 0) THEN
215!-- Ge the information out of the file
216    CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
217!-- Put the data into the database
218    CALL getdbwr &
219 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
220  ELSE
221!-- Get the value out of the database
222    CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)
223  ENDIF
224!-
225  jl=0
226  DO jj=1,size_2
227    DO ji=1,size_1
228      jl=jl+1
229      ret_val(ji,jj) = tmp_ret_val(jl)
230    ENDDO
231  ENDDO
232!----------------------
233END SUBROUTINE getinr2d
234!-
235!===
236!-
237SUBROUTINE getfilr (TARGET,status,fileorig,ret_val)
238!---------------------------------------------------------------------
239!- Subroutine that will extract from the file the values
240!- attributed to the keyword target
241!-
242!- REALS
243!- -----
244!-
245!- target   : in  : CHARACTER(LEN=*)  target for which we will
246!-                                    look in the file
247!- status   : out : INTEGER tells us from where we obtained the data
248!- fileorig : out : The index of the file from which the key comes
249!- ret_val  : out : REAL(nb_to_ret) values read
250!---------------------------------------------------------------------
251  IMPLICIT NONE
252!-
253  CHARACTER(LEN=*) :: TARGET
254  INTEGER :: status, fileorig
255  REAL,DIMENSION(:) :: ret_val
256!-
257  INTEGER :: nb_to_ret
258  INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt
259  CHARACTER(LEN=3)  :: cnt, tl, dl
260  CHARACTER(LEN=10) :: fmt
261  CHARACTER(LEN=30) :: full_target
262  CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
263  INTEGER :: full_target_sig
264  REAL :: compvalue
265!-
266  INTEGER,SAVE :: max_len = 0
267  LOGICAL,SAVE,ALLOCATABLE :: found(:)
268  LOGICAL :: def_beha
269  LOGICAL :: compressed = .FALSE.
270!---------------------------------------------------------------------
271  nb_to_ret = SIZE(ret_val)
272  CALL getin_read
273!-
274! Get the variables and memory we need
275!-
276  IF (max_len == 0) THEN
277    ALLOCATE(found(nb_to_ret))
278    max_len = nb_to_ret
279  ENDIF
280  IF (max_len < nb_to_ret) THEN
281    DEALLOCATE(found)
282    ALLOCATE(found(nb_to_ret))
283    max_len = nb_to_ret
284  ENDIF
285  found(:) = .FALSE.
286!-
287! See what we find in the files read
288!-
289  DO it=1,nb_to_ret
290!---
291!-
292!-- First try the target as it is
293!---
294    full_target = TARGET(1:len_TRIM(target))
295    CALL gensig (full_target,full_target_sig)
296    CALL find_sig (nb_lines,targetlist,full_target, &
297 &                 targetsiglist,full_target_sig,pos)
298!---
299!-- Another try
300!---
301    IF (pos < 0) THEN
302      WRITE(cnt,'(I3.3)') it
303      full_target = TARGET(1:len_TRIM(target))//'__'//cnt
304      CALL gensig (full_target,full_target_sig)
305      CALL find_sig (nb_lines,targetlist,full_target, &
306 &                   targetsiglist,full_target_sig,pos)
307    ENDIF
308!---
309!-- A priori we dont know from which file the target could come.
310!-- Thus by default we attribute it to the first file :
311!---
312    fileorig = 1
313!--
314    IF (pos > 0) THEN
315!----
316      found(it) = .TRUE.
317      fileorig = fromfile(pos)
318!-----
319!---- DECODE
320!-----
321      str_READ = TRIM(ADJUSTL(fichier(pos)))
322      str_READ_lower = str_READ
323      CALL strlowercase (str_READ_lower)
324!----
325      IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
326 &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
327 &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
328 &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
329        def_beha = .TRUE.
330      ELSE
331        def_beha = .FALSE.
332        len_str = LEN_TRIM(str_READ)
333        epos = INDEX(str_READ,'e')
334        ppos = INDEX(str_READ,'.')
335!------
336        IF (epos > 0) THEN
337          WRITE(tl,'(I3.3)') len_str
338          WRITE(dl,'(I3.3)') epos-ppos-1
339          fmt='(e'//tl//'.'//dl//')'
340          READ(str_READ,fmt) ret_val(it)
341        ELSE IF (ppos > 0) THEN
342          WRITE(tl,'(I3.3)') len_str
343          WRITE(dl,'(I3.3)') len_str-ppos
344          fmt='(f'//tl//'.'//dl//')'
345          READ(str_READ,fmt) ret_val(it)
346        ELSE
347          WRITE(tl,'(I3.3)') len_str
348          fmt = '(I'//tl//')'
349          READ(str_READ,fmt) int_tmp
350          ret_val(it) = REAL(int_tmp)
351        ENDIF
352      ENDIF
353!----
354      targetsiglist(pos) = -1
355!-----
356!---- Is this the value of a compressed field ?
357!-----
358      IF (compline(pos) > 0) THEN
359        IF (compline(pos) == nb_to_ret) THEN
360          compressed = .TRUE.
361          compvalue = ret_val(it)
362        ELSE
363          WRITE(*,*) 'WARNING from getfilr'
364          WRITE(*,*) 'For key ',TRIM(TARGET), &
365 & ' we have a compressed field but which does not have the right size.'
366          WRITE(*,*) 'We will try to fix that '
367          compressed = .TRUE.
368          compvalue = ret_val(it)
369        ENDIF
370      ENDIF
371    ELSE
372      found(it) = .FALSE.
373    ENDIF
374  ENDDO
375!--
376! If this is a compressed field then we will uncompress it
377!--
378  IF (compressed) THEN
379    DO it=1,nb_to_ret
380      IF (.NOT. found(it)) THEN
381        ret_val(it) = compvalue
382        found(it) = .TRUE.
383      ENDIF
384    ENDDO
385  ENDIF
386!-
387! Now we get the status for what we found
388!-
389  IF (def_beha) THEN
390    status = 2
391    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
392  ELSE
393    status_cnt = 0
394    DO it=1,nb_to_ret
395      IF (.NOT. found(it)) THEN
396        status_cnt = status_cnt+1
397        IF (nb_to_ret > 1) THEN
398          WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
399        ELSE
400          str_tmp = TRIM(TARGET)
401        ENDIF
402        WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
403      ENDIF
404    ENDDO
405!---
406    IF (status_cnt == 0) THEN
407      status = 1
408    ELSE IF (status_cnt == nb_to_ret) THEN
409      status = 2
410    ELSE
411      status = 3
412    ENDIF
413  ENDIF
414!---------------------
415END SUBROUTINE getfilr
416!-
417!=== INTEGER INTERFACES
418!-
419SUBROUTINE getinis (TARGET,ret_val)
420!---------------------------------------------------------------------
421!- Get a interer scalar. We first check if we find it
422!- in the database and if not we get it from the run.def
423!-
424!- getini1d and getini2d are written on the same pattern
425!---------------------------------------------------------------------
426  IMPLICIT NONE
427!-
428  CHARACTER(LEN=*) :: TARGET
429  INTEGER :: ret_val
430!-
431  INTEGER,DIMENSION(1) :: tmp_ret_val
432  INTEGER :: target_sig, pos, status=0, fileorig
433!---------------------------------------------------------------------
434!-
435! Compute the signature of the target
436!-
437  CALL gensig (TARGET,target_sig)
438!-
439! Do we have this target in our database ?
440!-
441  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
442!-
443  tmp_ret_val(1) = ret_val
444!-
445  IF (pos < 0) THEN
446!-- Ge the information out of the file
447    CALL getfili (TARGET,status,fileorig,tmp_ret_val)
448!-- Put the data into the database
449    CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
450    ELSE
451!-- Get the value out of the database
452    CALL getdbri (pos,1,TARGET,tmp_ret_val)
453  ENDIF
454  ret_val = tmp_ret_val(1)
455!---------------------
456END SUBROUTINE getinis
457!-
458!===
459!-
460SUBROUTINE getini1d (TARGET,ret_val)
461!---------------------------------------------------------------------
462!- See getinis for details. It is the same thing but for a vector
463!---------------------------------------------------------------------
464  IMPLICIT NONE
465!-
466  CHARACTER(LEN=*) :: TARGET
467  INTEGER,DIMENSION(:) :: ret_val
468!-
469  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
470  INTEGER,SAVE :: tmp_ret_size = 0
471  INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
472!---------------------------------------------------------------------
473!-
474! Compute the signature of the target
475!-
476  CALL gensig (TARGET,target_sig)
477!-
478! Do we have this target in our database ?
479!-
480  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
481!-
482  size_of_in = SIZE(ret_val)
483  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
484    ALLOCATE (tmp_ret_val(size_of_in))
485  ELSE IF (size_of_in > tmp_ret_size) THEN
486    DEALLOCATE (tmp_ret_val)
487    ALLOCATE (tmp_ret_val(size_of_in))
488    tmp_ret_size = size_of_in
489  ENDIF
490  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
491!-
492  IF (pos < 0) THEN
493!-- Ge the information out of the file
494    CALL getfili (TARGET,status,fileorig,tmp_ret_val)
495!-- Put the data into the database
496    CALL getdbwi &
497 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
498  ELSE
499!-- Get the value out of the database
500    CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)
501  ENDIF
502  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
503!----------------------
504END SUBROUTINE getini1d
505!-
506!===
507!-
508SUBROUTINE getini2d (TARGET,ret_val)
509!---------------------------------------------------------------------
510!- See getinis for details. It is the same thing but for a matrix
511!---------------------------------------------------------------------
512  IMPLICIT NONE
513!-
514  CHARACTER(LEN=*) :: TARGET
515  INTEGER,DIMENSION(:,:) :: ret_val
516!-
517  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
518  INTEGER,SAVE :: tmp_ret_size = 0
519  INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
520  INTEGER :: jl, jj, ji
521!---------------------------------------------------------------------
522!-
523! Compute the signature of the target
524!-
525  CALL gensig (TARGET,target_sig)
526!-
527! Do we have this target in our database ?
528!-
529  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
530!-
531  size_of_in = SIZE(ret_val)
532  size_1 = SIZE(ret_val,1)
533  size_2 = SIZE(ret_val,2)
534  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
535    ALLOCATE (tmp_ret_val(size_of_in))
536  ELSE IF (size_of_in > tmp_ret_size) THEN
537    DEALLOCATE (tmp_ret_val)
538    ALLOCATE (tmp_ret_val(size_of_in))
539    tmp_ret_size = size_of_in
540  ENDIF
541!-
542  jl=0
543  DO jj=1,size_2
544    DO ji=1,size_1
545      jl=jl+1
546      tmp_ret_val(jl) = ret_val(ji,jj)
547    ENDDO
548  ENDDO
549!-
550  IF (pos < 0) THEN
551!-- Ge the information out of the file
552    CALL getfili (TARGET,status,fileorig,tmp_ret_val)
553!-- Put the data into the database
554    CALL getdbwi &
555 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
556  ELSE
557!-- Get the value out of the database
558    CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)
559  ENDIF
560!-
561  jl=0
562  DO jj=1,size_2
563    DO ji=1,size_1
564      jl=jl+1
565      ret_val(ji,jj) = tmp_ret_val(jl)
566    ENDDO
567  ENDDO
568!----------------------
569END SUBROUTINE getini2d
570!-
571!===
572!-
573SUBROUTINE getfili (TARGET,status,fileorig,ret_val)
574!---------------------------------------------------------------------
575!- Subroutine that will extract from the file the values
576!- attributed to the keyword target
577!-
578!- INTEGER
579!- -------
580!-
581!- target   : in  : CHARACTER(LEN=*)  target for which we will
582!-                                    look in the file
583!- status   : out : INTEGER tells us from where we obtained the data
584!- fileorig : out : The index of the file from which the key comes
585!- ret_val  : out : INTEGER(nb_to_ret) values read
586!---------------------------------------------------------------------
587  IMPLICIT NONE
588!-
589  CHARACTER(LEN=*) :: TARGET
590  INTEGER :: status, fileorig
591  INTEGER :: ret_val(:)
592!-
593  INTEGER :: nb_to_ret
594  INTEGER :: it, pos, len_str, status_cnt
595  CHARACTER(LEN=3)  :: cnt, chlen
596  CHARACTER(LEN=10) ::  fmt
597  CHARACTER(LEN=30) :: full_target
598  CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
599  INTEGER :: full_target_sig
600  INTEGER :: compvalue
601!-
602  INTEGER,SAVE :: max_len = 0
603  LOGICAL,SAVE,ALLOCATABLE :: found(:)
604  LOGICAL :: def_beha
605  LOGICAL :: compressed = .FALSE.
606!---------------------------------------------------------------------
607  nb_to_ret = SIZE(ret_val)
608  CALL getin_read
609!-
610! Get the variables and memory we need
611!-
612  IF (max_len == 0) THEN
613    ALLOCATE(found(nb_to_ret))
614    max_len = nb_to_ret
615  ENDIF
616  IF (max_len < nb_to_ret) THEN
617    DEALLOCATE(found)
618    ALLOCATE(found(nb_to_ret))
619    max_len = nb_to_ret
620  ENDIF
621  found(:) = .FALSE.
622!-
623! See what we find in the files read
624!-
625  DO it=1,nb_to_ret
626!---
627!-- First try the target as it is
628!---
629    full_target = TARGET(1:len_TRIM(target))
630    CALL gensig (full_target,full_target_sig)
631    CALL find_sig (nb_lines,targetlist,full_target, &
632 &                 targetsiglist,full_target_sig,pos)
633!---
634!-- Another try
635!---
636    IF (pos < 0) THEN
637      WRITE(cnt,'(I3.3)') it
638      full_target = TARGET(1:len_TRIM(target))//'__'//cnt
639      CALL gensig (full_target,full_target_sig)
640      CALL find_sig (nb_lines,targetlist,full_target, &
641 &                   targetsiglist,full_target_sig,pos)
642    ENDIF
643!---
644!-- A priori we dont know from which file the target could come.
645!-- Thus by default we attribute it to the first file :
646!---
647    fileorig = 1
648!-
649    IF (pos > 0) THEN
650!-----
651      found(it) = .TRUE.
652      fileorig = fromfile(pos)
653!-----
654!---- DECODE
655!----
656      str_READ = TRIM(ADJUSTL(fichier(pos)))
657      str_READ_lower = str_READ
658      CALL strlowercase (str_READ_lower)
659!-----
660      IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
661 &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
662 &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
663 &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
664        def_beha = .TRUE.
665      ELSE
666        def_beha = .FALSE.
667        len_str = LEN_TRIM(str_READ)
668        WRITE(chlen,'(I3.3)') len_str
669        fmt = '(I'//chlen//')'
670        READ(str_READ,fmt) ret_val(it)
671      ENDIF
672!-----
673      targetsiglist(pos) = -1
674!-----
675!---- Is this the value of a compressed field ?
676!-----
677      IF (compline(pos) > 0) THEN
678        IF (compline(pos) == nb_to_ret) THEN
679          compressed = .TRUE.
680          compvalue = ret_val(it)
681        ELSE
682          WRITE(*,*) 'WARNING from getfilr'
683          WRITE(*,*) 'For key ',TRIM(TARGET), &
684 & ' we have a compressed field but which does not have the right size.'
685          WRITE(*,*) 'We will try to fix that '
686          compressed = .TRUE.
687          compvalue = ret_val(it)
688        ENDIF
689      ENDIF
690    ELSE
691      found(it) = .FALSE.
692    ENDIF
693  ENDDO
694!-
695! If this is a compressed field then we will uncompress it
696!-
697  IF (compressed) THEN
698    DO it=1,nb_to_ret
699      IF (.NOT. found(it)) THEN
700        ret_val(it) = compvalue
701        found(it) = .TRUE.
702      ENDIF
703    ENDDO
704  ENDIF
705!-
706! Now we get the status for what we found
707!-
708  IF (def_beha) THEN
709    status = 2
710    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
711  ELSE
712    status_cnt = 0
713    DO it=1,nb_to_ret
714      IF (.NOT. found(it)) THEN
715        status_cnt = status_cnt+1
716        IF (nb_to_ret > 1) THEN
717          WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
718        ELSE
719          str_tmp = TRIM(TARGET)
720        ENDIF
721        WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
722      ENDIF
723    ENDDO
724!---
725    IF (status_cnt == 0) THEN
726      status = 1
727    ELSE IF (status_cnt == nb_to_ret) THEN
728      status = 2
729    ELSE
730      status = 3
731    ENDIF
732  ENDIF
733!---------------------
734END SUBROUTINE getfili
735!-
736!=== CHARACTER INTERFACES
737!-
738SUBROUTINE getincs (TARGET,ret_val)
739!---------------------------------------------------------------------
740!- Get a CHARACTER scalar. We first check if we find it
741!- in the database and if not we get it from the run.def
742!-
743!- getinc1d and getinc2d are written on the same pattern
744!---------------------------------------------------------------------
745  IMPLICIT NONE
746!-
747  CHARACTER(LEN=*) :: TARGET
748  CHARACTER(LEN=*) :: ret_val
749!-
750  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
751  INTEGER :: target_sig, pos, status=0, fileorig
752!---------------------------------------------------------------------
753!-
754! Compute the signature of the target
755!-
756  CALL gensig (TARGET,target_sig)
757!-
758! Do we have this target in our database ?
759!-
760  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
761!-
762  tmp_ret_val(1) = ret_val
763!-
764  IF (pos < 0) THEN
765!-- Ge the information out of the file
766    CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
767!-- Put the data into the database
768    CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
769  ELSE
770!-- Get the value out of the database
771    CALL getdbrc (pos,1,TARGET,tmp_ret_val)
772  ENDIF
773  ret_val = tmp_ret_val(1)
774!---------------------
775END SUBROUTINE getincs
776!-
777!===
778!-
779SUBROUTINE getinc1d (TARGET,ret_val)
780!---------------------------------------------------------------------
781!- See getincs for details. It is the same thing but for a vector
782!---------------------------------------------------------------------
783  IMPLICIT NONE
784!-
785  CHARACTER(LEN=*) :: TARGET
786  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
787!-
788  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
789  INTEGER,SAVE :: tmp_ret_size = 0
790  INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
791!---------------------------------------------------------------------
792!-
793! Compute the signature of the target
794!-
795  CALL gensig (TARGET,target_sig)
796!-
797! Do we have this target in our database ?
798!-
799  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
800!-
801  size_of_in = SIZE(ret_val)
802  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
803    ALLOCATE (tmp_ret_val(size_of_in))
804  ELSE IF (size_of_in > tmp_ret_size) THEN
805    DEALLOCATE (tmp_ret_val)
806    ALLOCATE (tmp_ret_val(size_of_in))
807    tmp_ret_size = size_of_in
808  ENDIF
809  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
810!-
811  IF (pos < 0) THEN
812!-- Ge the information out of the file
813    CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
814!-- Put the data into the database
815    CALL getdbwc &
816 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
817  ELSE
818!-- Get the value out of the database
819    CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)
820  ENDIF
821  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
822!----------------------
823END SUBROUTINE getinc1d
824!-
825!===
826!-
827SUBROUTINE getinc2d (TARGET,ret_val)
828!---------------------------------------------------------------------
829!- See getincs for details. It is the same thing but for a matrix
830!---------------------------------------------------------------------
831  IMPLICIT NONE
832!-
833  CHARACTER(LEN=*) :: TARGET
834  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
835!-
836  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
837  INTEGER,SAVE :: tmp_ret_size = 0
838  INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
839  INTEGER :: jl,jj,ji
840!---------------------------------------------------------------------
841!-
842! Compute the signature of the target
843!-
844  CALL gensig (TARGET,target_sig)
845!-
846! Do we have this target in our database ?
847!-
848  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
849!-
850  size_of_in = SIZE(ret_val)
851  size_1 = SIZE(ret_val,1)
852  size_2 = SIZE(ret_val,2)
853  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
854    ALLOCATE (tmp_ret_val(size_of_in))
855  ELSE IF (size_of_in > tmp_ret_size) THEN
856    DEALLOCATE (tmp_ret_val)
857    ALLOCATE (tmp_ret_val(size_of_in))
858    tmp_ret_size = size_of_in
859  ENDIF
860!-
861  jl=0
862  DO jj=1,size_2
863    DO ji=1,size_1
864      jl=jl+1
865      tmp_ret_val(jl) = ret_val(ji,jj)
866    ENDDO
867  ENDDO
868!-
869  IF (pos < 0) THEN
870!-- Ge the information out of the file
871    CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
872!-- Put the data into the database
873    CALL getdbwc &
874 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
875  ELSE
876!-- Get the value out of the database
877    CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)
878  ENDIF
879!-
880  jl=0
881  DO jj=1,size_2
882    DO ji=1,size_1
883      jl=jl+1
884      ret_val(ji,jj) = tmp_ret_val(jl)
885    ENDDO
886  ENDDO
887!----------------------
888END SUBROUTINE getinc2d
889!-
890!===
891!-
892SUBROUTINE getfilc (TARGET,status,fileorig,ret_val)
893!---------------------------------------------------------------------
894!- Subroutine that will extract from the file the values
895!- attributed to the keyword target
896!-
897!- CHARACTER
898!- ---------
899!-
900!- target   : in  : CHARACTER(LEN=*)  target for which we will
901!-                                    look in the file
902!- status   : out : INTEGER tells us from where we obtained the data
903!- fileorig : out : The index of the file from which the key comes
904!- ret_val  : out : CHARACTER(nb_to_ret) values read
905!---------------------------------------------------------------------
906  IMPLICIT NONE
907!-
908!-
909  CHARACTER(LEN=*) :: TARGET
910  INTEGER :: status, fileorig
911  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
912!-
913  INTEGER :: nb_to_ret
914  INTEGER :: it, pos, len_str, status_cnt
915  CHARACTER(LEN=3)  :: cnt
916  CHARACTER(LEN=30) :: full_target
917  CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
918  INTEGER :: full_target_sig
919!-
920  INTEGER,SAVE :: max_len = 0
921  LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found
922  LOGICAL :: def_beha
923!---------------------------------------------------------------------
924  nb_to_ret = SIZE(ret_val)
925  CALL getin_read
926!-
927! Get the variables and memory we need
928!-
929  IF (max_len == 0) THEN
930    ALLOCATE(found(nb_to_ret))
931    max_len = nb_to_ret
932  ENDIF
933  IF (max_len < nb_to_ret) THEN
934    DEALLOCATE(found)
935    ALLOCATE(found(nb_to_ret))
936    max_len = nb_to_ret
937  ENDIF
938  found(:) = .FALSE.
939!-
940! See what we find in the files read
941!-
942  DO it=1,nb_to_ret
943!---
944!-- First try the target as it is
945    full_target = TARGET(1:len_TRIM(target))
946    CALL gensig (full_target,full_target_sig)
947    CALL find_sig (nb_lines,targetlist,full_target, &
948 &                 targetsiglist,full_target_sig,pos)
949!---
950!-- Another try
951!---
952    IF (pos < 0) THEN
953      WRITE(cnt,'(I3.3)') it
954      full_target = TARGET(1:len_TRIM(target))//'__'//cnt
955      CALL gensig (full_target,full_target_sig)
956      CALL find_sig (nb_lines,targetlist,full_target, &
957 &                   targetsiglist,full_target_sig,pos)
958    ENDIF
959!---
960!-- A priori we dont know from which file the target could come.
961!-- Thus by default we attribute it to the first file :
962!---
963    fileorig = 1
964!---
965    IF (pos > 0) THEN
966!-----
967      found(it) = .TRUE.
968      fileorig = fromfile(pos)
969!-----
970!---- DECODE
971!-----
972      str_READ = TRIM(ADJUSTL(fichier(pos)))
973      str_READ_lower = str_READ
974      CALL strlowercase (str_READ_lower)
975!-----
976      IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
977 &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
978 &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
979 &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
980        def_beha = .TRUE.
981      ELSE
982        def_beha = .FALSE.
983        len_str = LEN_TRIM(str_READ)
984        ret_val(it) = str_READ(1:len_str)
985      ENDIF
986!-----
987      targetsiglist(pos) = -1
988!-----
989    ELSE
990      found(it) = .FALSE.
991    ENDIF
992  ENDDO
993!-
994! Now we get the status for what we found
995!-
996  IF (def_beha) THEN
997    status = 2
998    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
999  ELSE
1000    status_cnt = 0
1001    DO it=1,nb_to_ret
1002      IF (.NOT. found(it)) THEN
1003        status_cnt = status_cnt+1
1004        IF (nb_to_ret > 1) THEN
1005          WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
1006        ELSE
1007          str_tmp = TARGET(1:len_TRIM(target))
1008        ENDIF
1009        WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
1010      ENDIF
1011    ENDDO
1012!-
1013    IF (status_cnt == 0) THEN
1014      status = 1
1015    ELSE IF (status_cnt == nb_to_ret) THEN
1016      status = 2
1017    ELSE
1018      status = 3
1019    ENDIF
1020  ENDIF
1021!---------------------
1022END SUBROUTINE getfilc
1023!-
1024!=== LOGICAL INTERFACES
1025!-
1026SUBROUTINE getinls (TARGET,ret_val)
1027!---------------------------------------------------------------------
1028!- Get a logical scalar. We first check if we find it
1029!- in the database and if not we get it from the run.def
1030!-
1031!- getinl1d and getinl2d are written on the same pattern
1032!---------------------------------------------------------------------
1033  IMPLICIT NONE
1034!-
1035  CHARACTER(LEN=*) :: TARGET
1036  LOGICAL :: ret_val
1037!-
1038  LOGICAL,DIMENSION(1) :: tmp_ret_val
1039  INTEGER :: target_sig, pos, status=0, fileorig
1040!---------------------------------------------------------------------
1041!-
1042! Compute the signature of the target
1043!-
1044  CALL gensig (TARGET,target_sig)
1045!-
1046! Do we have this target in our database ?
1047!-
1048  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
1049!-
1050  tmp_ret_val(1) = ret_val
1051!-
1052  IF (pos < 0) THEN
1053!-- Ge the information out of the file
1054    CALL getfill (TARGET,status,fileorig,tmp_ret_val)
1055!-- Put the data into the database
1056    CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
1057  ELSE
1058!-- Get the value out of the database
1059    CALL getdbrl (pos,1,TARGET,tmp_ret_val)
1060  ENDIF
1061  ret_val = tmp_ret_val(1)
1062!---------------------
1063END SUBROUTINE getinls
1064!-
1065!===
1066!-
1067SUBROUTINE getinl1d (TARGET,ret_val)
1068!---------------------------------------------------------------------
1069!- See getinls for details. It is the same thing but for a vector
1070!---------------------------------------------------------------------
1071  IMPLICIT NONE
1072!-
1073  CHARACTER(LEN=*) :: TARGET
1074  LOGICAL,DIMENSION(:) :: ret_val
1075!-
1076  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
1077  INTEGER,SAVE :: tmp_ret_size = 0
1078  INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
1079!---------------------------------------------------------------------
1080!-
1081! Compute the signature of the target
1082!-
1083  CALL gensig (TARGET,target_sig)
1084!-
1085! Do we have this target in our database ?
1086!-
1087  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
1088!-
1089  size_of_in = SIZE(ret_val)
1090  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
1091    ALLOCATE (tmp_ret_val(size_of_in))
1092  ELSE IF (size_of_in > tmp_ret_size) THEN
1093    DEALLOCATE (tmp_ret_val)
1094    ALLOCATE (tmp_ret_val(size_of_in))
1095    tmp_ret_size = size_of_in
1096  ENDIF
1097  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
1098!-
1099  IF (pos < 0) THEN
1100!-- Ge the information out of the file
1101    CALL getfill (TARGET,status,fileorig,tmp_ret_val)
1102!-- Put the data into the database
1103    CALL getdbwl &
1104 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
1105  ELSE
1106!-- Get the value out of the database
1107    CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)
1108  ENDIF
1109  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
1110!----------------------
1111END SUBROUTINE getinl1d
1112!-
1113!===
1114!-
1115SUBROUTINE getinl2d (TARGET,ret_val)
1116!---------------------------------------------------------------------
1117!- See getinls for details. It is the same thing but for a matrix
1118!---------------------------------------------------------------------
1119  IMPLICIT NONE
1120!-
1121  CHARACTER(LEN=*) :: TARGET
1122  LOGICAL,DIMENSION(:,:) :: ret_val
1123!-
1124  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
1125  INTEGER,SAVE :: tmp_ret_size = 0
1126  INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
1127  INTEGER :: jl,jj,ji
1128!---------------------------------------------------------------------
1129!-
1130! Compute the signature of the target
1131!-
1132  CALL gensig (TARGET,target_sig)
1133!-
1134! Do we have this target in our database ?
1135!-
1136  CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
1137!-
1138  size_of_in = SIZE(ret_val)
1139  size_1 = SIZE(ret_val,1)
1140  size_2 = SIZE(ret_val,2)
1141  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
1142    ALLOCATE (tmp_ret_val(size_of_in))
1143  ELSE IF (size_of_in > tmp_ret_size) THEN
1144    DEALLOCATE (tmp_ret_val)
1145    ALLOCATE (tmp_ret_val(size_of_in))
1146    tmp_ret_size = size_of_in
1147  ENDIF
1148!-
1149  jl=0
1150  DO jj=1,size_2
1151    DO ji=1,size_1
1152      jl=jl+1
1153      tmp_ret_val(jl) = ret_val(ji,jj)
1154    ENDDO
1155  ENDDO
1156!-
1157  IF (pos < 0) THEN
1158!-- Ge the information out of the file
1159    CALL getfill (TARGET,status,fileorig,tmp_ret_val)
1160!-- Put the data into the database
1161    CALL getdbwl &
1162 &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
1163  ELSE
1164!-- Get the value out of the database
1165    CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)
1166  ENDIF
1167!-
1168  jl=0
1169  DO jj=1,size_2
1170    DO ji=1,size_1
1171      jl=jl+1
1172      ret_val(ji,jj) = tmp_ret_val(jl)
1173    ENDDO
1174  ENDDO
1175!----------------------
1176END SUBROUTINE getinl2d
1177!-
1178!===
1179!-
1180SUBROUTINE getfill (TARGET,status,fileorig,ret_val)
1181!---------------------------------------------------------------------
1182!- Subroutine that will extract from the file the values
1183!- attributed to the keyword target
1184!-
1185!- LOGICAL
1186!- -------
1187!-
1188!- target   : in  : CHARACTER(LEN=*)  target for which we will
1189!-                                    look in the file
1190!- status   : out : INTEGER tells us from where we obtained the data
1191!- fileorig : out : The index of the file from which the key comes
1192!- ret_val  : out : LOGICAL(nb_to_ret) values read
1193!---------------------------------------------------------------------
1194  IMPLICIT NONE
1195!-
1196  CHARACTER(LEN=*) :: TARGET
1197  INTEGER :: status, fileorig
1198  LOGICAL,DIMENSION(:) :: ret_val
1199!-
1200  INTEGER :: nb_to_ret
1201  INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt
1202  CHARACTER(LEN=3)  :: cnt
1203  CHARACTER(LEN=30) :: full_target
1204  CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
1205  INTEGER :: full_target_sig
1206!-
1207  INTEGER,SAVE :: max_len = 0
1208  LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found
1209  LOGICAL :: def_beha
1210!---------------------------------------------------------------------
1211  nb_to_ret = SIZE(ret_val)
1212  CALL getin_read
1213!-
1214! Get the variables and memory we need
1215!-
1216  IF (max_len == 0) THEN
1217    ALLOCATE(found(nb_to_ret))
1218    max_len = nb_to_ret
1219  ENDIF
1220  IF (max_len < nb_to_ret) THEN
1221    DEALLOCATE(found)
1222    ALLOCATE(found(nb_to_ret))
1223    max_len = nb_to_ret
1224  ENDIF
1225  found(:) = .FALSE.
1226!-
1227! See what we find in the files read
1228!-
1229  DO it=1,nb_to_ret
1230!---
1231!-- First try the target as it is
1232!---
1233    full_target = TARGET(1:len_TRIM(target))
1234    CALL gensig (full_target,full_target_sig)
1235    CALL find_sig (nb_lines,targetlist,full_target, &
1236 &                 targetsiglist,full_target_sig,pos)
1237!---
1238!-- Another try
1239!---
1240    IF (pos < 0) THEN
1241      WRITE(cnt,'(I3.3)') it
1242      full_target = TARGET(1:len_TRIM(target))//'__'//cnt
1243      CALL gensig (full_target,full_target_sig)
1244      CALL find_sig (nb_lines,targetlist,full_target, &
1245 &                   targetsiglist,full_target_sig,pos)
1246    ENDIF
1247!---
1248!-- A priori we dont know from which file the target could come.
1249!-- Thus by default we attribute it to the first file :
1250!---
1251    fileorig = 1
1252!---
1253    IF (pos > 0) THEN
1254!-----
1255      found(it) = .TRUE.
1256      fileorig = fromfile(pos)
1257!-----
1258!---- DECODE
1259!-----
1260      str_READ = TRIM(ADJUSTL(fichier(pos)))
1261      str_READ_lower = str_READ
1262      CALL strlowercase (str_READ_lower)
1263!-----
1264      IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
1265 &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
1266 &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
1267 &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
1268        def_beha = .TRUE.
1269      ELSE
1270        def_beha = .FALSE.
1271        len_str = LEN_TRIM(str_READ)
1272        ipos_tr = -1
1273        ipos_fl = -1
1274!-------
1275        ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), &
1276 &                    INDEX(str_READ,'y'),INDEX(str_READ,'Y'))
1277        ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), &
1278 &                    INDEX(str_READ,'n'),INDEX(str_READ,'N'))
1279!-------
1280        IF (ipos_tr > 0) THEN
1281          ret_val(it) = .TRUE.
1282        ELSE IF (ipos_fl > 0) THEN
1283          ret_val(it) = .FALSE.
1284        ELSE
1285          WRITE(*,*) "ERROR : getfill : TARGET ", &
1286 &                   TRIM(TARGET)," is not of logical value"
1287          STOP 'getinl'
1288        ENDIF
1289      ENDIF
1290!-----
1291      targetsiglist(pos) = -1
1292!-----
1293    ELSE
1294!-
1295      found(it) = .FALSE.
1296!-
1297    ENDIF
1298!-
1299  ENDDO
1300!-
1301! Now we get the status for what we found
1302!-
1303  IF (def_beha) THEN
1304    status = 2
1305    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
1306  ELSE
1307    status_cnt = 0
1308    DO it=1,nb_to_ret
1309      IF (.NOT. found(it)) THEN
1310        status_cnt = status_cnt+1
1311        IF (nb_to_ret > 1) THEN
1312          WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
1313        ELSE
1314          str_tmp = TRIM(TARGET)
1315        ENDIF
1316        WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
1317      ENDIF
1318    ENDDO
1319!---
1320    IF (status_cnt == 0) THEN
1321      status = 1
1322    ELSE IF (status_cnt == nb_to_ret) THEN
1323      status = 2
1324    ELSE
1325      status = 3
1326    ENDIF
1327  ENDIF
1328!---------------------
1329END SUBROUTINE getfill
1330!-
1331!===
1332!-
1333SUBROUTINE getin_read
1334!---------------------------------------------------------------------
1335  IMPLICIT NONE
1336!-
1337  INTEGER,SAVE :: allread=0
1338  INTEGER,SAVE :: current,i
1339!---------------------------------------------------------------------
1340  IF (allread == 0) THEN
1341!-- Allocate a first set of memory.
1342    CALL getin_allockeys
1343    CALL getin_allocmem (1,0)
1344    CALL getin_allocmem (2,0)
1345    CALL getin_allocmem (3,0)
1346    CALL getin_allocmem (4,0)
1347!-- Start with reading the files
1348    nbfiles = 1
1349    filelist(1) = 'run.def'
1350    current = 1
1351    nb_lines = 0
1352!--
1353    DO WHILE (current <= nbfiles)
1354      CALL getin_readdef (current)
1355      current = current+1
1356    ENDDO
1357    allread = 1
1358    CALL getin_checkcohe ()
1359  ENDIF
1360!------------------------
1361END SUBROUTINE getin_read
1362!-
1363!===
1364!-
1365  SUBROUTINE getin_readdef(current)
1366!---------------------------------------------------------------------
1367!- This subroutine will read the files and only keep the
1368!- the relevant information. The information is kept as it
1369!- found in the file. The data will be analysed later.
1370!---------------------------------------------------------------------
1371  IMPLICIT NONE
1372!-
1373  INTEGER :: current
1374!-
1375  CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str
1376  CHARACTER(LEN=3) :: cnt
1377  INTEGER :: nb_lastkey
1378!-
1379  INTEGER :: eof, ptn, len_str, i, it, iund
1380  LOGICAL :: check = .FALSE.
1381!---------------------------------------------------------------------
1382  eof = 0
1383  ptn = 1
1384  nb_lastkey = 0
1385!-
1386  IF (check) THEN
1387    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
1388  ENDIF
1389!-
1390  OPEN (22,file=filelist(current),ERR=9997,STATUS="OLD")
1391!-
1392  DO WHILE (eof /= 1)
1393!---
1394    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
1395    len_str = LEN_TRIM(READ_str)
1396    ptn = INDEX(READ_str,'=')
1397!---
1398    IF (ptn > 0) THEN
1399!---- Get the target
1400      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
1401!---- Make sure that if a vector keyword has the right length
1402      iund =  INDEX(key_str,'__')
1403      IF (iund > 0) THEN
1404        SELECTCASE( len_trim(key_str)-iund )
1405          CASE(2)
1406            READ(key_str(iund+2:len_trim(key_str)),'(I1)') it
1407          CASE(3)
1408            READ(key_str(iund+2:len_trim(key_str)),'(I2)') it
1409          CASE(4)
1410            READ(key_str(iund+2:len_trim(key_str)),'(I3)') it
1411          CASE DEFAULT
1412            it = -1
1413        END SELECT
1414        IF (it > 0) THEN
1415          WRITE(cnt,'(I3.3)') it
1416          key_str = key_str(1:iund+1)//cnt
1417        ELSE
1418          WRITE(*,*) &
1419 &          'getin_readdef : A very strange key has just been found'
1420          WRITE(*,*) 'getin_readdef : ',key_str(1:len_TRIM(key_str))
1421          STOP 'getin_readdef'
1422        ENDIF
1423      ENDIF
1424!---- Prepare the content
1425      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
1426      CALL nocomma (NEW_str)
1427      CALL cmpblank (NEW_str)
1428      NEW_str  = TRIM(ADJUSTL(NEW_str))
1429      IF (check) THEN
1430        WRITE(*,*) &
1431 &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
1432      ENDIF
1433!---- Decypher the content of NEW_str
1434!-
1435!---- This has to be a new key word, thus :
1436      nb_lastkey = 0
1437!----
1438      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1439!----
1440    ELSE IF (len_str > 0) THEN
1441!---- Prepare the key if we have an old one to which
1442!---- we will add the line just read
1443      IF (nb_lastkey > 0) THEN
1444        iund =  INDEX(last_key,'__')
1445        IF (iund > 0) THEN
1446!-------- We only continue a keyword, thus it is easy
1447          key_str = last_key(1:iund-1)
1448        ELSE
1449          IF (nb_lastkey /= 1) THEN
1450            WRITE(*,*) &
1451 &   'getin_readdef : An error has occured. We can not have a scalar'
1452            WRITE(*,*) 'getin_readdef : keywod and a vector content'
1453            STOP 'getin_readdef'
1454          ENDIF
1455!-------- The last keyword needs to be transformed into a vector.
1456          targetlist(nb_lines) = &
1457 &          last_key(1:MIN(len_trim(last_key),30))//'__001'
1458          CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
1459          key_str = last_key(1:len_TRIM(last_key))
1460        ENDIF
1461      ENDIF
1462!---- Prepare the content
1463      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
1464      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
1465    ELSE
1466!---- If we have an empty line the the keyword finishes
1467      nb_lastkey = 0
1468      IF (check) THEN
1469        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
1470      ENDIF
1471    ENDIF
1472  ENDDO
1473!-
1474  CLOSE(22)
1475!-
1476  IF (check) THEN
1477    OPEN (22,file='run.def.test')
1478    DO i=1,nb_lines
1479      WRITE(22,*) targetlist(i)," : ",fichier(i)
1480    ENDDO
1481    CLOSE(22)
1482  ENDIF
1483!-
1484  RETURN
1485!-
14869997 WRITE(*,*) "getin_readdef : Could not open file ", &
1487          & TRIM(filelist(current))
1488!---------------------------
1489END SUBROUTINE getin_readdef
1490!-
1491!===
1492!-
1493SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
1494!---------------------------------------------------------------------
1495!- This subroutine is going to decypher the line.
1496!- It essentialy checks how many items are included and
1497!- it they can be attached to a key.
1498!---------------------------------------------------------------------
1499  IMPLICIT NONE
1500!-
1501! ARGUMENTS
1502!-
1503  INTEGER :: current, nb_lastkey
1504  CHARACTER(LEN=*) :: key_str, NEW_str, last_key
1505!-
1506! LOCAL
1507!-
1508  INTEGER :: len_str, blk, nbve, starpos
1509  CHARACTER(LEN=100) :: tmp_str, new_key, mult
1510  CHARACTER(LEN=3)   :: cnt, chlen
1511  CHARACTER(LEN=10)  :: fmt
1512!---------------------------------------------------------------------
1513  len_str = LEN_TRIM(NEW_str)
1514  blk = INDEX(NEW_str(1:len_str),' ')
1515  tmp_str = NEW_str(1:len_str)
1516!-
1517! If the key is a new file then we take it up. Else
1518! we save the line and go on.
1519!-
1520  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
1521    DO WHILE (blk > 0)
1522      IF (nbfiles+1 > max_files) THEN
1523        WRITE(*,*) 'FATAL ERROR : Too many files to include'
1524        STOP 'getin_readdef'
1525      ENDIF
1526!-----
1527      nbfiles = nbfiles+1
1528      filelist(nbfiles) = tmp_str(1:blk)
1529!-----
1530      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1531      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
1532    ENDDO
1533!---
1534    IF (nbfiles+1 > max_files) THEN
1535      WRITE(*,*) 'FATAL ERROR : Too many files to include'
1536      STOP 'getin_readdef'
1537    ENDIF
1538!---
1539    nbfiles =  nbfiles+1
1540    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
1541!---
1542    last_key = 'INCLUDEDEF'
1543    nb_lastkey = 1
1544  ELSE
1545!-
1546!-- We are working on a new line of input
1547!-
1548    nb_lines = nb_lines+1
1549    IF (nb_lines > max_lines) THEN
1550      WRITE(*,*) &
1551 &      'Too many line in the run.def files. You need to increase'
1552      WRITE(*,*) 'the parameter max_lines in the module getincom.'
1553      STOP 'getin_decrypt'
1554    ENDIF
1555!-
1556!-- First we solve the issue of conpressed information. Once
1557!-- this is done all line can be handled in the same way.
1558!-
1559    starpos = INDEX(NEW_str(1:len_str),'*')
1560    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
1561 &                    .AND.(tmp_str(1:1) /= "'") ) THEN
1562!-----
1563      IF (INDEX(key_str(1:len_TRIM(key_str)),'__') > 0) THEN
1564        WRITE(*,*) 'ERROR : getin_decrypt'
1565        WRITE(*,*) &
1566&         'We can not have a compressed field of values for in a'
1567        WRITE(*,*) &
1568&         'vector notation. If a target is of the type TARGET__1'
1569        WRITE(*,*) 'then only a scalar value is allowed'
1570        WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str))
1571        STOP 'getin_decrypt'
1572      ENDIF
1573!-
1574!---- Read the multiplied
1575!-
1576      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
1577!---- Construct the new string and its parameters
1578      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
1579      len_str = LEN_TRIM(NEW_str)
1580      blk = INDEX(NEW_str(1:len_str),' ')
1581      IF (blk > 1) THEN
1582        WRITE(*,*) &
1583 &       'This is a strange behavior of getin_decrypt you could report'
1584      ENDIF
1585      WRITE(chlen,'(I3.3)') LEN_TRIM(mult)
1586      fmt = '(I'//chlen//')'
1587      READ(mult,fmt) compline(nb_lines)
1588!---
1589    ELSE
1590      compline(nb_lines) = -1
1591    ENDIF
1592!-
1593!-- If there is no space wthin the line then the target is a scalar
1594!-- or the element of a properly written vector.
1595!-- (ie of the type TARGET__1)
1596!-
1597    IF (    (blk <= 1) &
1598 &      .OR.(tmp_str(1:1) == '"') &
1599 &      .OR.(tmp_str(1:1) == "'") ) THEN
1600!-
1601      IF (nb_lastkey == 0) THEN
1602!------ Save info of current keyword as a scalar
1603!------ if it is not a continuation
1604        targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str),30))
1605        last_key = key_str(1:MIN(len_trim(key_str),30))
1606        nb_lastkey = 1
1607      ELSE
1608!------ We are continuing a vector so the keyword needs
1609!------ to get the underscores
1610        WRITE(cnt,'(I3.3)') nb_lastkey+1
1611        targetlist(nb_lines) = &
1612 &        key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
1613        last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
1614        nb_lastkey = nb_lastkey+1
1615      ENDIF
1616!-----
1617      CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
1618      fichier(nb_lines) = NEW_str(1:len_str)
1619      fromfile(nb_lines) = current
1620    ELSE
1621!-
1622!---- If there are blanks whithin the line then we are dealing
1623!---- with a vector and we need to split it in many entries
1624!---- with the TRAGET__1 notation.
1625!----
1626!---- Test if the targer is not already a vector target !
1627!-
1628      IF (INDEX(TRIM(key_str),'__') > 0) THEN
1629        WRITE(*,*) 'ERROR : getin_decrypt'
1630        WRITE(*,*) 'We have found a mixed vector notation'
1631        WRITE(*,*) 'If a target is of the type TARGET__1'
1632        WRITE(*,*) 'then only a scalar value is allowed'
1633        WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str))
1634        STOP 'getin_decrypt'
1635      ENDIF
1636!-
1637      nbve = nb_lastkey
1638      nbve = nbve+1
1639      WRITE(cnt,'(I3.3)') nbve
1640!-
1641      DO WHILE (blk > 0)
1642!-
1643!------ Save the content of target__nbve
1644!-
1645        fichier(nb_lines) = tmp_str(1:blk)
1646        new_key =  key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
1647        targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30))
1648        CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
1649        fromfile(nb_lines) = current
1650!-
1651        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1652        blk = INDEX(TRIM(tmp_str),' ')
1653!-
1654        nb_lines = nb_lines+1
1655        IF (nb_lines > max_lines) THEN
1656          WRITE(*,*) &
1657 &          'Too many line in the run.def files. You need to increase'
1658          WRITE(*,*) 'the parameter max_lines in the module getincom.'
1659          STOP 'getin_decrypt'
1660        ENDIF
1661        nbve = nbve+1
1662        WRITE(cnt,'(I3.3)') nbve
1663!-
1664      ENDDO
1665!-
1666!---- Save the content of the last target
1667!-
1668      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
1669      new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
1670      targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30))
1671      CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
1672      fromfile(nb_lines) = current
1673!-
1674      last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
1675      nb_lastkey = nbve
1676!-
1677    ENDIF
1678!-
1679  ENDIF
1680!---------------------------
1681END SUBROUTINE getin_decrypt
1682!-
1683!===
1684!-
1685SUBROUTINE getin_checkcohe ()
1686!---------------------------------------------------------------------
1687!- This subroutine checks for redundancies.
1688!---------------------------------------------------------------------
1689  IMPLICIT NONE
1690!-
1691! Arguments
1692!-
1693!-
1694! LOCAL
1695!-
1696  INTEGER :: line,i,sig
1697  INTEGER :: found
1698  CHARACTER(LEN=30) :: str
1699!---------------------------------------------------------------------
1700  DO line=1,nb_lines-1
1701!-
1702    CALL find_sig &
1703 &    (nb_lines-line,targetlist(line+1:nb_lines),targetlist(line), &
1704 &     targetsiglist(line+1:nb_lines),targetsiglist(line),found)
1705!---
1706!-- IF we have found it we have a problem to solve.
1707!---
1708    IF (found > 0) THEN
1709      WRITE(*,*) 'COUNT : ', &
1710 &  COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1)
1711!-----
1712      WRITE(*,*) &
1713 & 'getin_checkcohe : Found a problem on key ',targetlist(line)
1714      WRITE(*,*) &
1715 & 'getin_checkcohe : The following values were encoutered :'
1716      WRITE(*,*) &
1717 & '                ',TRIM(targetlist(line)), &
1718 &               targetsiglist(line),' == ',fichier(line)
1719      WRITE(*,*) &
1720 & '                ',TRIM(targetlist(line+found)), &
1721 &               targetsiglist(line+found),' == ',fichier(line+found)
1722      WRITE(*,*) &
1723 & 'getin_checkcohe : We will keep only the last value'
1724!-----
1725      targetsiglist(line) = 1
1726    ENDIF
1727  ENDDO
1728!-
1729END SUBROUTINE getin_checkcohe
1730!-
1731!===
1732!-
1733SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
1734!---------------------------------------------------------------------
1735  IMPLICIT NONE
1736!-
1737  INTEGER :: unit, eof, nb_lastkey
1738  CHARACTER(LEN=100) :: dummy
1739  CHARACTER(LEN=100) :: out_string
1740  CHARACTER(LEN=1) :: first
1741!---------------------------------------------------------------------
1742  first="#"
1743  eof = 0
1744  out_string = "    "
1745!-
1746  DO WHILE (first == "#")
1747    READ (unit,'(a100)',ERR=9998,END=7778) dummy
1748    dummy = TRIM(ADJUSTL(dummy))
1749    first=dummy(1:1)
1750    IF (first == "#") THEN
1751      nb_lastkey = 0
1752    ENDIF
1753  ENDDO
1754  out_string=dummy
1755!-
1756  RETURN
1757!-
17589998 WRITE(*,*) " GETIN_SKIPAFEW : Error while reading file "
1759  STOP 'getin_skipafew'
1760!-
17617778 eof = 1
1762!----------------------------
1763END SUBROUTINE getin_skipafew
1764!-
1765!=== INTEGER database INTERFACE
1766!-
1767SUBROUTINE getdbwi &
1768 &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
1769!---------------------------------------------------------------------
1770!- Write the INTEGER data into the data base
1771!---------------------------------------------------------------------
1772  IMPLICIT NONE
1773!-
1774  CHARACTER(LEN=*) :: target
1775  INTEGER :: target_sig, status, fileorig, size_of_in
1776  INTEGER,DIMENSION(:) :: tmp_ret_val
1777!---------------------------------------------------------------------
1778!-
1779! First check if we have sufficiant space for the new key
1780!-
1781  IF (nb_keys+1 > keymemsize) THEN
1782    CALL getin_allockeys ()
1783  ENDIF
1784!-
1785! Fill out the items of the data base
1786!-
1787  nb_keys = nb_keys+1
1788  keysig(nb_keys) = target_sig
1789  keystr(nb_keys) = target(1:MIN(len_trim(target),30))
1790  keystatus(nb_keys) = status
1791  keytype(nb_keys) = 1
1792  keyfromfile(nb_keys) = fileorig
1793!-
1794! Can we compress the data base entry ?
1795!-
1796  IF (     (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1797 &    .AND.(size_of_in > compress_lim)) THEN
1798    keymemstart(nb_keys) = intmempos+1
1799    keycompress(nb_keys) = size_of_in
1800    keymemlen(nb_keys) = 1
1801  ELSE
1802    keymemstart(nb_keys) = intmempos+1
1803    keycompress(nb_keys) = -1
1804    keymemlen(nb_keys) = size_of_in
1805  ENDIF
1806!-
1807! Before writing the actual size lets see if we have the space
1808!-
1809  IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN
1810    CALL getin_allocmem (1,keymemlen(nb_keys))
1811  ENDIF
1812!-
1813  intmem(keymemstart(nb_keys): &
1814 &       keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1815 &  tmp_ret_val(1:keymemlen(nb_keys))
1816  intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1817!---------------------
1818END SUBROUTINE getdbwi
1819!-
1820!===
1821!-
1822SUBROUTINE getdbri (pos,size_of_in,target,tmp_ret_val)
1823!---------------------------------------------------------------------
1824!- Read the required variables in the database for INTEGERS
1825!---------------------------------------------------------------------
1826  IMPLICIT NONE
1827!-
1828  INTEGER :: pos, size_of_in
1829  CHARACTER(LEN=*) :: target
1830  INTEGER,DIMENSION(:) :: tmp_ret_val
1831!---------------------------------------------------------------------
1832  IF (keytype(pos) /= 1) THEN
1833    WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
1834    STOP 'getdbri'
1835  ENDIF
1836!-
1837  IF (keycompress(pos) > 0) THEN
1838    IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN
1839      WRITE(*,*) &
1840 &      'FATAL ERROR : Wrong compression length for keyword ',target
1841      STOP 'getdbri'
1842    ELSE
1843      tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos))
1844    ENDIF
1845  ELSE
1846    IF (keymemlen(pos) /= size_of_in) THEN
1847      WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
1848      STOP 'getdbri'
1849    ELSE
1850      tmp_ret_val(1:size_of_in) = &
1851 &      intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1852    ENDIF
1853  ENDIF
1854!---------------------
1855END SUBROUTINE getdbri
1856!-
1857!=== REAL database INTERFACE
1858!-
1859SUBROUTINE getdbwr &
1860 &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
1861!---------------------------------------------------------------------
1862!- Write the REAL data into the data base
1863!---------------------------------------------------------------------
1864  IMPLICIT NONE
1865!-
1866  CHARACTER(LEN=*) :: target
1867  INTEGER :: target_sig, status, fileorig, size_of_in
1868  REAL,DIMENSION(:) :: tmp_ret_val
1869!---------------------------------------------------------------------
1870!-
1871! First check if we have sufficiant space for the new key
1872!-
1873  IF (nb_keys+1 > keymemsize) THEN
1874    CALL getin_allockeys ()
1875  ENDIF
1876!-
1877! Fill out the items of the data base
1878!-
1879  nb_keys = nb_keys+1
1880  keysig(nb_keys) = target_sig
1881  keystr(nb_keys) = target(1:MIN(len_trim(target),30))
1882  keystatus(nb_keys) = status
1883  keytype(nb_keys) = 2
1884  keyfromfile(nb_keys) = fileorig
1885!-
1886! Can we compress the data base entry ?
1887!-
1888  IF (     (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1889&     .AND.(size_of_in > compress_lim)) THEN
1890    keymemstart(nb_keys) = realmempos+1
1891    keycompress(nb_keys) = size_of_in
1892    keymemlen(nb_keys) = 1
1893  ELSE
1894    keymemstart(nb_keys) = realmempos+1
1895    keycompress(nb_keys) = -1
1896    keymemlen(nb_keys) = size_of_in
1897  ENDIF
1898!-
1899! Before writing the actual size lets see if we have the space
1900!-
1901  IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
1902    CALL getin_allocmem (2,keymemlen(nb_keys))
1903  ENDIF
1904!-
1905  realmem(keymemstart(nb_keys): &
1906 &        keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1907 &  tmp_ret_val(1:keymemlen(nb_keys))
1908  realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1909!---------------------
1910END SUBROUTINE getdbwr
1911!-
1912!===
1913!-
1914SUBROUTINE getdbrr (pos,size_of_in,target,tmp_ret_val)
1915!---------------------------------------------------------------------
1916!- Read the required variables in the database for REALS
1917!---------------------------------------------------------------------
1918  IMPLICIT NONE
1919!-
1920  INTEGER :: pos, size_of_in
1921  CHARACTER(LEN=*) :: target
1922  REAL,DIMENSION(:) :: tmp_ret_val
1923!---------------------------------------------------------------------
1924  IF (keytype(pos) /= 2) THEN
1925    WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
1926    STOP 'getdbrr'
1927  ENDIF
1928!-
1929  IF (keycompress(pos) > 0) THEN
1930    IF (    (keycompress(pos) /= size_of_in) &
1931 &      .OR.(keymemlen(pos) /= 1) ) THEN
1932      WRITE(*,*) &
1933 &      'FATAL ERROR : Wrong compression length for keyword ',target
1934      STOP 'getdbrr'
1935    ELSE
1936      tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos))
1937    ENDIF
1938  ELSE
1939    IF (keymemlen(pos) /= size_of_in) THEN
1940      WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
1941      STOP 'getdbrr'
1942    ELSE
1943      tmp_ret_val(1:size_of_in) = &
1944 &      realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1945    ENDIF
1946  ENDIF
1947!---------------------
1948END SUBROUTINE getdbrr
1949!-
1950!=== CHARACTER database INTERFACE
1951!-
1952SUBROUTINE getdbwc &
1953 &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
1954!---------------------------------------------------------------------
1955!- Write the CHARACTER data into the data base
1956!---------------------------------------------------------------------
1957  IMPLICIT NONE
1958!-
1959  CHARACTER(LEN=*) :: target
1960  INTEGER :: target_sig,status,fileorig,size_of_in
1961  CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val
1962!---------------------------------------------------------------------
1963!-
1964! First check if we have sufficiant space for the new key
1965!-
1966  IF (nb_keys+1 > keymemsize) THEN
1967    CALL getin_allockeys ()
1968  ENDIF
1969!-
1970! Fill out the items of the data base
1971!-
1972  nb_keys = nb_keys+1
1973  keysig(nb_keys) = target_sig
1974  keystr(nb_keys) = target(1:MIN(len_trim(target),30))
1975  keystatus(nb_keys) = status
1976  keytype(nb_keys) = 3
1977  keyfromfile(nb_keys) = fileorig
1978  keymemstart(nb_keys) = charmempos+1
1979  keymemlen(nb_keys) = size_of_in
1980!-
1981! Before writing the actual size lets see if we have the space
1982!-
1983  IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
1984    CALL getin_allocmem (3,keymemlen(nb_keys))
1985  ENDIF
1986!-
1987  charmem(keymemstart(nb_keys): &
1988 &        keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1989 &  tmp_ret_val(1:keymemlen(nb_keys))
1990  charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1991!---------------------
1992END SUBROUTINE getdbwc
1993!-
1994!===
1995!-
1996SUBROUTINE getdbrc(pos,size_of_in,target,tmp_ret_val)
1997!---------------------------------------------------------------------
1998!- Read the required variables in the database for CHARACTER
1999!---------------------------------------------------------------------
2000  IMPLICIT NONE
2001!-
2002  INTEGER :: pos, size_of_in
2003  CHARACTER(LEN=*) :: target
2004  CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val
2005!---------------------------------------------------------------------
2006  IF (keytype(pos) /= 3) THEN
2007    WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
2008    STOP 'getdbrc'
2009  ENDIF
2010!-
2011  IF (keymemlen(pos) /= size_of_in) THEN
2012    WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
2013    STOP 'getdbrc'
2014  ELSE
2015    tmp_ret_val(1:size_of_in) = &
2016 &    charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
2017  ENDIF
2018!---------------------
2019END SUBROUTINE getdbrc
2020!-
2021!=== LOGICAL database INTERFACE
2022!-
2023SUBROUTINE getdbwl &
2024 &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
2025!---------------------------------------------------------------------
2026!- Write the LOGICAL data into the data base
2027!---------------------------------------------------------------------
2028  IMPLICIT NONE
2029!-
2030  CHARACTER(LEN=*) :: target
2031  INTEGER :: target_sig, status, fileorig, size_of_in
2032  LOGICAL,DIMENSION(:) :: tmp_ret_val
2033!---------------------------------------------------------------------
2034!-
2035! First check if we have sufficiant space for the new key
2036!-
2037  IF (nb_keys+1 > keymemsize) THEN
2038    CALL getin_allockeys ()
2039  ENDIF
2040!-
2041! Fill out the items of the data base
2042!-
2043  nb_keys = nb_keys+1
2044  keysig(nb_keys) = target_sig
2045  keystr(nb_keys) = target(1:MIN(len_trim(target),30))
2046  keystatus(nb_keys) = status
2047  keytype(nb_keys) = 4
2048  keyfromfile(nb_keys) = fileorig
2049  keymemstart(nb_keys) = logicmempos+1
2050  keymemlen(nb_keys) = size_of_in
2051!-
2052! Before writing the actual size lets see if we have the space
2053!-
2054  IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN
2055    CALL getin_allocmem (4,keymemlen(nb_keys))
2056  ENDIF
2057!-
2058  logicmem(keymemstart(nb_keys): &
2059 &         keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
2060 &  tmp_ret_val(1:keymemlen(nb_keys))
2061  logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
2062!---------------------
2063END SUBROUTINE getdbwl
2064!-
2065!===
2066!-
2067SUBROUTINE getdbrl(pos,size_of_in,target,tmp_ret_val)
2068!---------------------------------------------------------------------
2069!- Read the required variables in the database for LOGICALS
2070!---------------------------------------------------------------------
2071  IMPLICIT NONE
2072!-
2073  INTEGER :: pos, size_of_in
2074  CHARACTER(LEN=*) :: target
2075  LOGICAL,DIMENSION(:) :: tmp_ret_val
2076!---------------------------------------------------------------------
2077  IF (keytype(pos) /= 4) THEN
2078    WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
2079    STOP 'getdbrl'
2080  ENDIF
2081!-
2082  IF (keymemlen(pos) /= size_of_in) THEN
2083    WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
2084    STOP 'getdbrl'
2085  ELSE
2086    tmp_ret_val(1:size_of_in) = &
2087 &    logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
2088  ENDIF
2089!---------------------
2090END SUBROUTINE getdbrl
2091!-
2092!===
2093!-
2094SUBROUTINE getin_allockeys ()
2095!---------------------------------------------------------------------
2096  IMPLICIT NONE
2097!-
2098  INTEGER,ALLOCATABLE :: tmp_int(:)
2099  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
2100!-
2101  INTEGER :: ier
2102!---------------------------------------------------------------------
2103!-
2104! Either nothing exists in these arrays and it is easy to do
2105!-
2106  IF (keymemsize == 0) THEN
2107!-
2108    ALLOCATE(keysig(memslabs),stat=ier)
2109    IF (ier /= 0) THEN
2110      WRITE(*,*) &
2111 &      'getin_allockeys : Can not allocate keysig to size ', &
2112 &      memslabs
2113      STOP
2114    ENDIF
2115!-
2116    ALLOCATE(keystr(memslabs),stat=ier)
2117    IF (ier /= 0) THEN
2118      WRITE(*,*) &
2119 &      'getin_allockeys : Can not allocate keystr to size ', &
2120 &      memslabs
2121      STOP
2122    ENDIF
2123!-
2124    ALLOCATE(keystatus(memslabs),stat=ier)
2125    IF (ier /= 0) THEN
2126      WRITE(*,*) &
2127 &      'getin_allockeys : Can not allocate keystatus to size ', &
2128 &      memslabs
2129      STOP
2130    ENDIF
2131!-
2132    ALLOCATE(keytype(memslabs),stat=ier)
2133    IF (ier /= 0) THEN
2134      WRITE(*,*) &
2135 &      'getin_allockeys : Can not allocate keytype to size ', &
2136 &      memslabs
2137      STOP
2138    ENDIF
2139!-
2140    ALLOCATE(keycompress(memslabs),stat=ier)
2141    IF (ier /= 0) THEN
2142      WRITE(*,*) &
2143 &      'getin_allockeys : Can not allocate keycompress to size ', &
2144 &      memslabs
2145      STOP
2146    ENDIF
2147!-
2148    ALLOCATE(keyfromfile(memslabs),stat=ier)
2149    IF (ier /= 0) THEN
2150      WRITE(*,*) &
2151 &      'getin_allockeys : Can not allocate keyfromfile to size ', &
2152 &      memslabs
2153      STOP
2154    ENDIF
2155!-
2156    ALLOCATE(keymemstart(memslabs),stat=ier)
2157    IF (ier /= 0) THEN
2158      WRITE(*,*) &
2159 &      'getin_allockeys : Can not allocate keymemstart to size ', &
2160 &      memslabs
2161      STOP
2162    ENDIF
2163!-
2164    ALLOCATE(keymemlen(memslabs),stat=ier)
2165    IF (ier /= 0) THEN
2166      WRITE(*,*) &
2167 &      'getin_allockeys : Can not allocate keymemlen to size ', &
2168 &      memslabs
2169      STOP
2170    ENDIF
2171!-
2172    nb_keys = 0
2173    keymemsize = memslabs
2174    keycompress(:) = -1
2175!-
2176  ELSE
2177!-
2178!-- There is something already in the memory,
2179!-- we need to transfer and reallocate.
2180!-
2181    ALLOCATE(tmp_str(keymemsize),stat=ier)
2182    IF (ier /= 0) THEN
2183      WRITE(*,*) &
2184 &      'getin_allockeys : Can not allocate tmp_str to size ', &
2185 &      keymemsize
2186      STOP
2187    ENDIF
2188!-
2189    ALLOCATE(tmp_int(keymemsize),stat=ier)
2190    IF (ier /= 0) THEN
2191      WRITE(*,*) &
2192 &      'getin_allockeys : Can not allocate tmp_int to size ', &
2193 &      keymemsize
2194      STOP
2195    ENDIF
2196!-
2197    tmp_int(1:keymemsize) = keysig(1:keymemsize)
2198    DEALLOCATE(keysig)
2199    ALLOCATE(keysig(keymemsize+memslabs),stat=ier)
2200    IF (ier /= 0) THEN
2201      WRITE(*,*) &
2202 &      'getin_allockeys : Can not allocate keysig to size ', &
2203 &      keymemsize+memslabs
2204      STOP
2205    ENDIF
2206    keysig(1:keymemsize) = tmp_int(1:keymemsize)
2207!-
2208    tmp_str(1:keymemsize) = keystr(1:keymemsize)
2209    DEALLOCATE(keystr)
2210    ALLOCATE(keystr(keymemsize+memslabs),stat=ier)
2211    IF (ier /= 0) THEN
2212      WRITE(*,*) &
2213 &      'getin_allockeys : Can not allocate keystr to size ', &
2214 &      keymemsize+memslabs
2215      STOP
2216    ENDIF
2217    keystr(1:keymemsize) = tmp_str(1:keymemsize)
2218!-
2219    tmp_int(1:keymemsize) = keystatus(1:keymemsize)
2220    DEALLOCATE(keystatus)
2221    ALLOCATE(keystatus(keymemsize+memslabs),stat=ier)
2222    IF (ier /= 0) THEN
2223      WRITE(*,*) &
2224 &      'getin_allockeys : Can not allocate keystatus to size ', &
2225 &      keymemsize+memslabs
2226      STOP
2227    ENDIF
2228    keystatus(1:keymemsize) = tmp_int(1:keymemsize)
2229!-
2230    tmp_int(1:keymemsize) = keytype(1:keymemsize)
2231    DEALLOCATE(keytype)
2232    ALLOCATE(keytype(keymemsize+memslabs),stat=ier)
2233    IF (ier /= 0) THEN
2234      WRITE(*,*) &
2235 &      'getin_allockeys : Can not allocate keytype to size ', &
2236 &      keymemsize+memslabs
2237      STOP
2238    ENDIF
2239    keytype(1:keymemsize) = tmp_int(1:keymemsize)
2240!-
2241    tmp_int(1:keymemsize) = keycompress(1:keymemsize)
2242    DEALLOCATE(keycompress)
2243    ALLOCATE(keycompress(keymemsize+memslabs),stat=ier)
2244    IF (ier /= 0) THEN
2245      WRITE(*,*) &
2246 &      'getin_allockeys : Can not allocate keycompress to size ', &
2247 &      keymemsize+memslabs
2248      STOP
2249    ENDIF
2250    keycompress(:) = -1
2251    keycompress(1:keymemsize) = tmp_int(1:keymemsize)
2252!-
2253    tmp_int(1:keymemsize) = keyfromfile(1:keymemsize)
2254    DEALLOCATE(keyfromfile)
2255    ALLOCATE(keyfromfile(keymemsize+memslabs),stat=ier)
2256    IF (ier /= 0) THEN
2257      WRITE(*,*) &
2258 &      'getin_allockeys : Can not allocate keyfromfile to size ', &
2259 &      keymemsize+memslabs
2260      STOP
2261    ENDIF
2262    keyfromfile(1:keymemsize) = tmp_int(1:keymemsize)
2263!-
2264    tmp_int(1:keymemsize) = keymemstart(1:keymemsize)
2265    DEALLOCATE(keymemstart)
2266    ALLOCATE(keymemstart(keymemsize+memslabs),stat=ier)
2267    IF (ier /= 0) THEN
2268      WRITE(*,*) &
2269 &      'getin_allockeys : Can not allocate keymemstart to size ', &
2270 &      keymemsize+memslabs
2271      STOP
2272    ENDIF
2273    keymemstart(1:keymemsize) = tmp_int(1:keymemsize)
2274!-
2275    tmp_int(1:keymemsize) = keymemlen(1:keymemsize)
2276    DEALLOCATE(keymemlen)
2277    ALLOCATE(keymemlen(keymemsize+memslabs),stat=ier)
2278    IF (ier /= 0) THEN
2279      WRITE(*,*) &
2280 &      'getin_allockeys : Can not allocate keymemlen to size ', &
2281 &      keymemsize+memslabs
2282      STOP
2283    ENDIF
2284    keymemlen(1:keymemsize) = tmp_int(1:keymemsize)
2285!-
2286    keymemsize = keymemsize+memslabs
2287!-
2288    DEALLOCATE(tmp_int)
2289    DEALLOCATE(tmp_str)
2290  ENDIF
2291!-----------------------------
2292END SUBROUTINE getin_allockeys
2293!-
2294!===
2295!-
2296SUBROUTINE getin_allocmem (type,len_wanted)
2297!---------------------------------------------------------------------
2298!- Allocate the memory of the data base for all 4 types of memory
2299!-
2300!- 1 = INTEGER
2301!- 2 = REAL
2302!- 3 = CHAR
2303!- 4 = LOGICAL
2304!---------------------------------------------------------------------
2305  IMPLICIT NONE
2306!-
2307  INTEGER :: type, len_wanted
2308!-
2309  INTEGER,ALLOCATABLE :: tmp_int(:)
2310  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
2311  REAL,ALLOCATABLE :: tmp_real(:)
2312  LOGICAL,ALLOCATABLE :: tmp_logic(:)
2313  INTEGER :: ier
2314!---------------------------------------------------------------------
2315  SELECT CASE (type)
2316  CASE(1)
2317    IF (intmemsize == 0) THEN
2318      ALLOCATE(intmem(memslabs),stat=ier)
2319      IF (ier /= 0) THEN
2320        WRITE(*,*) &
2321 &    'getin_allocmem : Unable to allocate db-memory intmem to ', &
2322 &    memslabs
2323        STOP
2324      ENDIF
2325      intmemsize=memslabs
2326    ELSE
2327      ALLOCATE(tmp_int(intmemsize),stat=ier)
2328      IF (ier /= 0) THEN
2329        WRITE(*,*) &
2330 &    'getin_allocmem : Unable to allocate tmp_int to ', &
2331 &    intmemsize
2332        STOP
2333      ENDIF
2334      tmp_int(1:intmemsize) = intmem(1:intmemsize)
2335      DEALLOCATE(intmem)
2336      ALLOCATE(intmem(intmemsize+MAX(memslabs,len_wanted)),stat=ier)
2337      IF (ier /= 0) THEN
2338        WRITE(*,*) &
2339 &    'getin_allocmem : Unable to re-allocate db-memory intmem to ', &
2340 &    intmemsize+MAX(memslabs,len_wanted)
2341        STOP
2342      ENDIF
2343      intmem(1:intmemsize) = tmp_int(1:intmemsize)
2344      intmemsize = intmemsize+MAX(memslabs,len_wanted)
2345      DEALLOCATE(tmp_int)
2346    ENDIF
2347  CASE(2)
2348    IF (realmemsize == 0) THEN
2349      ALLOCATE(realmem(memslabs),stat=ier)
2350      IF (ier /= 0) THEN
2351        WRITE(*,*) &
2352 &    'getin_allocmem : Unable to allocate db-memory realmem to ', &
2353 &    memslabs
2354        STOP
2355      ENDIF
2356      realmemsize =  memslabs
2357    ELSE
2358      ALLOCATE(tmp_real(realmemsize),stat=ier)
2359      IF (ier /= 0) THEN
2360        WRITE(*,*) &
2361 &    'getin_allocmem : Unable to allocate tmp_real to ', &
2362 &    realmemsize
2363        STOP
2364      ENDIF
2365      tmp_real(1:realmemsize) = realmem(1:realmemsize)
2366      DEALLOCATE(realmem)
2367      ALLOCATE(realmem(realmemsize+MAX(memslabs,len_wanted)),stat=ier)
2368      IF (ier /= 0) THEN
2369        WRITE(*,*) &
2370 &    'getin_allocmem : Unable to re-allocate db-memory realmem to ', &
2371 &    realmemsize+MAX(memslabs,len_wanted)
2372        STOP
2373      ENDIF
2374      realmem(1:realmemsize) = tmp_real(1:realmemsize)
2375      realmemsize = realmemsize+MAX(memslabs,len_wanted)
2376      DEALLOCATE(tmp_real)
2377    ENDIF
2378  CASE(3)
2379    IF (charmemsize == 0) THEN
2380      ALLOCATE(charmem(memslabs),stat=ier)
2381      IF (ier /= 0) THEN
2382        WRITE(*,*) &
2383 &    'getin_allocmem : Unable to allocate db-memory charmem to ', &
2384 &    memslabs
2385        STOP
2386      ENDIF
2387      charmemsize = memslabs
2388    ELSE
2389      ALLOCATE(tmp_char(charmemsize),stat=ier)
2390      IF (ier /= 0) THEN
2391        WRITE(*,*) &
2392 &    'getin_allocmem : Unable to allocate tmp_char to ', &
2393 &    charmemsize
2394        STOP
2395      ENDIF
2396      tmp_char(1:charmemsize) = charmem(1:charmemsize)
2397      DEALLOCATE(charmem)
2398      ALLOCATE(charmem(charmemsize+MAX(memslabs,len_wanted)),stat=ier)
2399      IF (ier /= 0) THEN
2400        WRITE(*,*) &
2401 &    'getin_allocmem : Unable to re-allocate db-memory charmem to ', &
2402 &    charmemsize+MAX(memslabs,len_wanted)
2403        STOP
2404      ENDIF
2405      charmem(1:charmemsize) = tmp_char(1:charmemsize)
2406      charmemsize = charmemsize+MAX(memslabs,len_wanted)
2407      DEALLOCATE(tmp_char)
2408    ENDIF
2409  CASE(4)
2410    IF (logicmemsize == 0) THEN
2411      ALLOCATE(logicmem(memslabs),stat=ier)
2412      IF (ier /= 0) THEN
2413        WRITE(*,*) &
2414 &    'getin_allocmem : Unable to allocate db-memory logicmem to ', &
2415 &    memslabs
2416        STOP
2417      ENDIF
2418      logicmemsize = memslabs
2419    ELSE
2420      ALLOCATE(tmp_logic(logicmemsize),stat=ier)
2421      IF (ier /= 0) THEN
2422        WRITE(*,*) &
2423 &    'getin_allocmem : Unable to allocate tmp_logic to ', &
2424 &    logicmemsize
2425        STOP
2426      ENDIF
2427      tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize)
2428      DEALLOCATE(logicmem)
2429      ALLOCATE(logicmem(logicmemsize+MAX(memslabs,len_wanted)),stat=ier)
2430      IF (ier /= 0) THEN
2431        WRITE(*,*) &
2432 &    'getin_allocmem : Unable to re-allocate db-memory logicmem to ', &
2433 &    logicmemsize+MAX(memslabs,len_wanted)
2434        STOP
2435      ENDIF
2436      logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize)
2437      logicmemsize = logicmemsize+MAX(memslabs,len_wanted)
2438      DEALLOCATE(tmp_logic)
2439    ENDIF
2440  CASE DEFAULT
2441    WRITE(*,*) 'getin_allocmem : Unknown type : ',type
2442    STOP
2443  END SELECT
2444!----------------------------
2445END SUBROUTINE getin_allocmem
2446!-
2447!===
2448!-
2449SUBROUTINE getin_dump (fileprefix)
2450!---------------------------------------------------------------------
2451!- This subroutine will dump the content of the database into  file
2452!- which has the same format as the run.def. The idea is that the user
2453!- can see which parameters were used and re-use the file for another
2454!- run.
2455!-
2456!- The argument file allows the user to change the name of the file
2457!- in which the data will be archived
2458!---------------------------------------------------------------------
2459  IMPLICIT NONE
2460!-
2461  CHARACTER(*),OPTIONAL :: fileprefix
2462!-
2463  CHARACTER(LEN=80) :: usedfileprefix = "used"
2464  INTEGER :: ikey,if,iff,iv
2465  CHARACTER(LEN=3) :: tmp3
2466  CHARACTER(LEN=100) :: tmp_str, used_filename
2467  LOGICAL :: check = .FALSE.
2468!---------------------------------------------------------------------
2469  IF (PRESENT(fileprefix)) THEN
2470    usedfileprefix = fileprefix(1:MIN(len_trim(fileprefix),80))
2471  ENDIF
2472!-
2473  DO if=1,nbfiles
2474!---
2475    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
2476    IF (check) THEN
2477      WRITE(*,*) &
2478 &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
2479      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
2480    ENDIF
2481    OPEN(unit=76,file=used_filename)
2482!-
2483!-- If this is the first file we need to add the list
2484!-- of file which belong to it
2485!-
2486    IF ( (if == 1) .AND. (nbfiles > 1) ) THEN
2487      WRITE(76,*) '# '
2488      WRITE(76,*) '# This file is linked to the following files :'
2489      WRITE(76,*) '# '
2490      DO iff=2,nbfiles
2491        WRITE(76,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
2492      ENDDO
2493      WRITE(76,*) '# '
2494    ENDIF
2495!---
2496    DO ikey=1,nb_keys
2497!-
2498!---- Is this key form this file ?
2499!-
2500      IF (keyfromfile(ikey) == if) THEN
2501!-
2502!---- Write some comments
2503!-
2504        WRITE(76,*) '#'
2505        SELECT CASE (keystatus(ikey))
2506        CASE(1)
2507          WRITE(76,*) '# Values of ', &
2508 &          TRIM(keystr(ikey)),' comes from the run.def.'
2509        CASE(2)
2510          WRITE(76,*) '# Values of ', &
2511 &          TRIM(keystr(ikey)),' are all defaults.'
2512        CASE(3)
2513          WRITE(76,*) '# Values of ', &
2514 &          TRIM(keystr(ikey)),' are a mix of run.def and defaults.'
2515        CASE DEFAULT
2516          WRITE(76,*) '# Dont know from where the value of ', &
2517 &          TRIM(keystr(ikey)),' comes.'
2518        END SELECT
2519        WRITE(76,*) '#'
2520!-
2521!---- Write the values
2522!-
2523        SELECT CASE (keytype(ikey))
2524!-
2525        CASE(1)
2526          IF (keymemlen(ikey) == 1) THEN
2527            IF (keycompress(ikey) < 0) THEN
2528              WRITE(76,*) &
2529 &              TRIM(keystr(ikey)),' = ',intmem(keymemstart(ikey))
2530            ELSE
2531              WRITE(76,*) &
2532 &              TRIM(keystr(ikey)),' = ',keycompress(ikey), &
2533 &              ' * ',intmem(keymemstart(ikey))
2534            ENDIF
2535          ELSE
2536            DO iv=0,keymemlen(ikey)-1
2537              WRITE(tmp3,'(I3.3)') iv+1
2538              WRITE(76,*) &
2539 &              TRIM(keystr(ikey)),'__',tmp3, &
2540 &              ' = ',intmem(keymemstart(ikey)+iv)
2541            ENDDO
2542          ENDIF
2543!-
2544        CASE(2)
2545          IF (keymemlen(ikey) == 1) THEN
2546            IF (keycompress(ikey) < 0) THEN
2547              WRITE(76,*) &
2548 &              TRIM(keystr(ikey)),' = ',realmem(keymemstart(ikey))
2549            ELSE
2550              WRITE(76,*) &
2551 &              TRIM(keystr(ikey)),' = ',keycompress(ikey),&
2552                   & ' * ',realmem(keymemstart(ikey))
2553            ENDIF
2554          ELSE
2555            DO iv=0,keymemlen(ikey)-1
2556              WRITE(tmp3,'(I3.3)') iv+1
2557              WRITE(76,*) &
2558 &              TRIM(keystr(ikey)),'__',tmp3, &
2559 &              ' = ',realmem(keymemstart(ikey)+iv)
2560            ENDDO
2561          ENDIF
2562        CASE(3)
2563          IF (keymemlen(ikey) == 1) THEN
2564            tmp_str = charmem(keymemstart(ikey))
2565            WRITE(76,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str)
2566          ELSE
2567            DO iv=0,keymemlen(ikey)-1
2568              WRITE(tmp3,'(I3.3)') iv+1
2569              tmp_str = charmem(keymemstart(ikey)+iv)
2570              WRITE(76,*) &
2571 &              TRIM(keystr(ikey)),'__',tmp3,' = ',TRIM(tmp_str)
2572            ENDDO
2573          ENDIF
2574        CASE(4)
2575          IF (keymemlen(ikey) == 1) THEN
2576            IF (logicmem(keymemstart(ikey))) THEN
2577              WRITE(76,*) TRIM(keystr(ikey)),' = TRUE '
2578            ELSE
2579              WRITE(76,*) TRIM(keystr(ikey)),' = FALSE '
2580            ENDIF
2581          ELSE
2582            DO iv=0,keymemlen(ikey)-1
2583              WRITE(tmp3,'(I3.3)') iv+1
2584              IF (logicmem(keymemstart(ikey)+iv)) THEN
2585                WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = TRUE '
2586              ELSE
2587                WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = FALSE '
2588              ENDIF
2589            ENDDO
2590          ENDIF
2591!-
2592        CASE DEFAULT
2593          WRITE(*,*) &
2594 &          'FATAL ERROR : Unknown type for variable ', &
2595 &          TRIM(keystr(ikey))
2596          STOP 'getin_dump'
2597        END SELECT
2598      ENDIF
2599    ENDDO
2600!-
2601    CLOSE(unit=76)
2602!-
2603  ENDDO
2604!------------------------
2605END SUBROUTINE getin_dump
2606!-
2607!===
2608!-
2609END MODULE ioipsl_getincom
Note: See TracBrowser for help on using the repository browser.