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

Annotation of /trunk/IOIPSL/getincom.f90

Parent Directory Parent Directory | Revision Log Revision Log

Revision 32 - (hide annotations)
Tue Apr 6 17:52:58 2010 UTC (14 years, 1 month ago) by guez
Original Path: trunk/libf/IOIPSL/getincom.f90
File size: 76596 byte(s) 
Split "stringop.f90" into single-procedure files. Gathered files in directory
"IOIPSL/Stringop".

Split "flincom.f90" into "flincom.f90" and "flinget.f90". Removed
unused procedures from module "flincom". Removed unused argument
"filename" of procedure "flinopen_nozoom".

Removed unused files.

Split "grid_change.f90" into "grid_change.f90" and
"gr_phy_write_3d.f90".

Removed unused procedures from modules "calendar", "ioipslmpp",
"grid_atob", "gath_cpl" and "getincom". Removed unused procedures in
files "ppm3d.f" and "thermcell.f".

Split "mathelp.f90" into "mathelp.f90" and "mathop.f90".

Removed unused variable "dpres" of module "comvert".

Use argument "itau" instead of local variables "iadvtr" and "first" to
control algorithm in procedure "fluxstokenc".

Removed unused arguments of procedure "integrd".

Removed useless computations at the end of procedure "leapfrog".

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