/[lmdze]/trunk/libf/IOIPSL/getincom.f90
ViewVC logotype

Annotation of /trunk/libf/IOIPSL/getincom.f90

Parent Directory Parent Directory | Revision Log Revision Log

Revision 30 - (hide annotations)
Thu Apr 1 09:07:28 2010 UTC (14 years, 2 months ago) by guez
File size: 82689 byte(s) 
Imported Source files of the external library "IOIPSL_Lionel" into
"libf/IOIPSL".

Split "cray.f90" into "scopy.f90" and "ssum.f90".

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