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

Annotation of /trunk/IOIPSL/getincom2.f90

Parent Directory Parent Directory | Revision Log Revision Log

Revision 51 - (hide annotations)
Tue Sep 20 09:14:34 2011 UTC (12 years, 8 months ago) by guez
Original Path: trunk/libf/IOIPSL/getincom2.f90
File size: 51851 byte(s) 
Split "getincom.f90" into "getincom.f90" and "getincom2.f90". Split
"nuage.f" into "nuage.f90", "diagcld1.f90" and "diagcld2.f90". Created
module "chem" from included file "chem.h". Moved "YOEGWD.f90" to
directory "Orography".

In "physiq", for evaporation of water, "zlsdcp" was equal to
"zlvdc". Removed useless variables.
1 guez 51 MODULE getincom2
2    
3     ! From getincom.f90, version 2.0 2004/04/05 14:47:48
4    
5     use gensig_m, only: gensig
6     use find_sig_m, only: find_sig
7    
8     IMPLICIT NONE
9    
10     INTEGER, PARAMETER :: max_files=100
11     CHARACTER(LEN=100), DIMENSION(max_files), SAVE :: filelist
12     INTEGER, SAVE :: nbfiles
13    
14     INTEGER, PARAMETER :: max_lines=500
15     INTEGER, SAVE :: nb_lines
16     CHARACTER(LEN=100), DIMENSION(max_lines), SAVE :: fichier
17     INTEGER, DIMENSION(max_lines), SAVE :: targetsiglist, fromfile, compline
18     CHARACTER(LEN=30), DIMENSION(max_lines), SAVE :: targetlist
19    
20     ! The data base of parameters
21    
22     INTEGER, PARAMETER :: memslabs=200
23     INTEGER, PARAMETER :: compress_lim = 20
24    
25     INTEGER, SAVE :: nb_keys=0
26     INTEGER, SAVE :: keymemsize=0
27     INTEGER, SAVE, ALLOCATABLE :: keysig(:)
28     CHARACTER(LEN=30), SAVE, ALLOCATABLE :: keystr(:)
29    
30     ! keystatus definition
31     ! keystatus = 1 : Value comes from run.def
32     ! keystatus = 2 : Default value is used
33     ! keystatus = 3 : Some vector elements were taken from default
34    
35     INTEGER, SAVE, ALLOCATABLE :: keystatus(:)
36    
37     ! keytype definition
38     ! keytype = 1 : Interger
39     ! keytype = 2 : Real
40     ! keytype = 3 : Character
41     ! keytype = 4 : Logical
42    
43     INTEGER, SAVE, ALLOCATABLE :: keytype(:)
44    
45     ! Allow compression for keys (only for integer and real)
46     ! keycompress < 0 : not compresses
47     ! keycompress > 0 : number of repeat of the value
48    
49     INTEGER, SAVE, ALLOCATABLE :: keycompress(:)
50     INTEGER, SAVE, ALLOCATABLE :: keyfromfile(:)
51    
52     INTEGER, SAVE, ALLOCATABLE :: keymemstart(:)
53     INTEGER, SAVE, ALLOCATABLE :: keymemlen(:)
54    
55     INTEGER, SAVE, ALLOCATABLE :: intmem(:)
56     INTEGER, SAVE :: intmemsize=0, intmempos=0
57     REAL, SAVE, ALLOCATABLE :: realmem(:)
58     INTEGER, SAVE :: realmemsize=0, realmempos=0
59     CHARACTER(LEN=100), SAVE, ALLOCATABLE :: charmem(:)
60     INTEGER, SAVE :: charmemsize=0, charmempos=0
61     LOGICAL, SAVE, ALLOCATABLE :: logicmem(:)
62     INTEGER, SAVE :: logicmemsize=0, logicmempos=0
63    
64     CONTAINS
65    
66     SUBROUTINE getfilr(MY_TARGET, status, fileorig, ret_val)
67    
68     ! Subroutine that will extract from the file the values attributed
69     ! to the keyword MY_TARGET
70    
71     ! REALS
72    
73     ! MY_TARGET : in : CHARACTER(LEN=*) target for which we will
74     ! look in the file
75     ! status : out : INTEGER tells us from where we obtained the data
76     ! fileorig : out : The index of the file from which the key comes
77     ! ret_val : out : REAL(nb_to_ret) values read
78    
79     use strlowercase_m, only: strlowercase
80    
81     CHARACTER(LEN=*) MY_TARGET
82     INTEGER :: status, fileorig
83     REAL, DIMENSION(:) :: ret_val
84    
85     INTEGER :: nb_to_ret
86     INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt
87     CHARACTER(LEN=3) :: cnt, tl, dl
88     CHARACTER(LEN=10) :: fmt
89     CHARACTER(LEN=30) :: full_target
90     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
91     INTEGER :: full_target_sig
92     REAL :: compvalue
93    
94     INTEGER, SAVE :: max_len = 0
95     LOGICAL, SAVE, ALLOCATABLE :: found(:)
96     LOGICAL :: def_beha
97     LOGICAL :: compressed = .FALSE.
98    
99     nb_to_ret = SIZE(ret_val)
100     CALL getin_read
101    
102     ! Get the variables and memory we need
103    
104     IF (max_len == 0) THEN
105     ALLOCATE(found(nb_to_ret))
106     max_len = nb_to_ret
107     ENDIF
108     IF (max_len < nb_to_ret) THEN
109     DEALLOCATE(found)
110     ALLOCATE(found(nb_to_ret))
111     max_len = nb_to_ret
112     ENDIF
113     found(:) = .FALSE.
114    
115     ! See what we find in the files read
116    
117     DO it=1, nb_to_ret
118    
119    
120     ! First try the target as it is
121    
122     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))
123     CALL gensig (full_target, full_target_sig)
124     CALL find_sig (nb_lines, targetlist, full_target, &
125     & targetsiglist, full_target_sig, pos)
126    
127     ! Another try
128    
129     IF (pos < 0) THEN
130     WRITE(cnt, '(I3.3)') it
131     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt
132     CALL gensig (full_target, full_target_sig)
133     CALL find_sig (nb_lines, targetlist, full_target, &
134     & targetsiglist, full_target_sig, pos)
135     ENDIF
136    
137     ! A priori we dont know from which file the target could come.
138     ! Thus by default we attribute it to the first file :
139    
140     fileorig = 1
141    
142     IF (pos > 0) THEN
143    
144     found(it) = .TRUE.
145     fileorig = fromfile(pos)
146    
147     ! DECODE
148    
149     str_READ = TRIM(ADJUSTL(fichier(pos)))
150     str_READ_lower = str_READ
151     CALL strlowercase (str_READ_lower)
152    
153     IF ( ( (INDEX(str_READ_lower, 'def') == 1) &
154     & .AND.(LEN_TRIM(str_READ_lower) == 3) ) &
155     & .OR.( (INDEX(str_READ_lower, 'default') == 1) &
156     & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN
157     def_beha = .TRUE.
158     ELSE
159     def_beha = .FALSE.
160     len_str = LEN_TRIM(str_READ)
161     epos = INDEX(str_READ, 'e')
162     ppos = INDEX(str_READ, '.')
163    
164     IF (epos > 0) THEN
165     WRITE(tl, '(I3.3)') len_str
166     WRITE(dl, '(I3.3)') epos-ppos-1
167     fmt='(e'//tl//'.'//dl//')'
168     READ(str_READ, fmt) ret_val(it)
169     ELSE IF (ppos > 0) THEN
170     WRITE(tl, '(I3.3)') len_str
171     WRITE(dl, '(I3.3)') len_str-ppos
172     fmt='(f'//tl//'.'//dl//')'
173     READ(str_READ, fmt) ret_val(it)
174     ELSE
175     WRITE(tl, '(I3.3)') len_str
176     fmt = '(I'//tl//')'
177     READ(str_READ, fmt) int_tmp
178     ret_val(it) = REAL(int_tmp)
179     ENDIF
180     ENDIF
181    
182     targetsiglist(pos) = -1
183    
184     ! Is this the value of a compressed field ?
185    
186     IF (compline(pos) > 0) THEN
187     IF (compline(pos) == nb_to_ret) THEN
188     compressed = .TRUE.
189     compvalue = ret_val(it)
190     ELSE
191     WRITE(*, *) 'WARNING from getfilr'
192     WRITE(*, *) 'For key ', TRIM(MY_TARGET), &
193     & ' we have a compressed field but which does not have the right size.'
194     WRITE(*, *) 'We will try to fix that '
195     compressed = .TRUE.
196     compvalue = ret_val(it)
197     ENDIF
198     ENDIF
199     ELSE
200     found(it) = .FALSE.
201     ENDIF
202     ENDDO
203    
204     ! If this is a compressed field then we will uncompress it
205    
206     IF (compressed) THEN
207     DO it=1, nb_to_ret
208     IF (.NOT. found(it)) THEN
209     ret_val(it) = compvalue
210     found(it) = .TRUE.
211     ENDIF
212     ENDDO
213     ENDIF
214    
215     ! Now we get the status for what we found
216    
217     IF (def_beha) THEN
218     status = 2
219     WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)
220     ELSE
221     status_cnt = 0
222     DO it=1, nb_to_ret
223     IF (.NOT. found(it)) THEN
224     status_cnt = status_cnt+1
225     IF (nb_to_ret > 1) THEN
226     WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it
227     ELSE
228     str_tmp = TRIM(MY_TARGET)
229     ENDIF
230     WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)
231     ENDIF
232     ENDDO
233    
234     IF (status_cnt == 0) THEN
235     status = 1
236     ELSE IF (status_cnt == nb_to_ret) THEN
237     status = 2
238     ELSE
239     status = 3
240     ENDIF
241     ENDIF
242    
243     END SUBROUTINE getfilr
244    
245     !**************************************************************
246    
247     SUBROUTINE getfili(MY_TARGET, status, fileorig, ret_val)
248    
249     ! Subroutine that will extract from the file the values
250     ! attributed to the keyword MY_TARGET
251    
252     ! INTEGER
253     ! -------
254    
255     ! MY_TARGET : in : CHARACTER(LEN=*) target for which we will
256     ! look in the file
257     ! status : out : INTEGER tells us from where we obtained the data
258     ! fileorig : out : The index of the file from which the key comes
259     ! ret_val : out : INTEGER(nb_to_ret) values read
260    
261    
262     use strlowercase_m, only: strlowercase
263    
264     CHARACTER(LEN=*) :: MY_TARGET
265     INTEGER :: status, fileorig
266     INTEGER :: ret_val(:)
267    
268     INTEGER :: nb_to_ret
269     INTEGER :: it, pos, len_str, status_cnt
270     CHARACTER(LEN=3) :: cnt, chlen
271     CHARACTER(LEN=10) :: fmt
272     CHARACTER(LEN=30) :: full_target
273     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
274     INTEGER :: full_target_sig
275     INTEGER :: compvalue
276    
277     INTEGER, SAVE :: max_len = 0
278     LOGICAL, SAVE, ALLOCATABLE :: found(:)
279     LOGICAL :: def_beha
280     LOGICAL :: compressed = .FALSE.
281    
282     nb_to_ret = SIZE(ret_val)
283     CALL getin_read
284    
285     ! Get the variables and memory we need
286    
287     IF (max_len == 0) THEN
288     ALLOCATE(found(nb_to_ret))
289     max_len = nb_to_ret
290     ENDIF
291     IF (max_len < nb_to_ret) THEN
292     DEALLOCATE(found)
293     ALLOCATE(found(nb_to_ret))
294     max_len = nb_to_ret
295     ENDIF
296     found(:) = .FALSE.
297    
298     ! See what we find in the files read
299    
300     DO it=1, nb_to_ret
301    
302     ! First try the target as it is
303    
304     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))
305     CALL gensig (full_target, full_target_sig)
306     CALL find_sig (nb_lines, targetlist, full_target, &
307     & targetsiglist, full_target_sig, pos)
308    
309     ! Another try
310    
311     IF (pos < 0) THEN
312     WRITE(cnt, '(I3.3)') it
313     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt
314     CALL gensig (full_target, full_target_sig)
315     CALL find_sig (nb_lines, targetlist, full_target, &
316     & targetsiglist, full_target_sig, pos)
317     ENDIF
318    
319     ! A priori we dont know from which file the target could come.
320     ! Thus by default we attribute it to the first file :
321    
322     fileorig = 1
323    
324     IF (pos > 0) THEN
325    
326     found(it) = .TRUE.
327     fileorig = fromfile(pos)
328    
329     ! DECODE
330    
331     str_READ = TRIM(ADJUSTL(fichier(pos)))
332     str_READ_lower = str_READ
333     CALL strlowercase (str_READ_lower)
334    
335     IF ( ( (INDEX(str_READ_lower, 'def') == 1) &
336     & .AND.(LEN_TRIM(str_READ_lower) == 3) ) &
337     & .OR.( (INDEX(str_READ_lower, 'default') == 1) &
338     & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN
339     def_beha = .TRUE.
340     ELSE
341     def_beha = .FALSE.
342     len_str = LEN_TRIM(str_READ)
343     WRITE(chlen, '(I3.3)') len_str
344     fmt = '(I'//chlen//')'
345     READ(str_READ, fmt) ret_val(it)
346     ENDIF
347    
348     targetsiglist(pos) = -1
349    
350     ! Is this the value of a compressed field ?
351    
352     IF (compline(pos) > 0) THEN
353     IF (compline(pos) == nb_to_ret) THEN
354     compressed = .TRUE.
355     compvalue = ret_val(it)
356     ELSE
357     WRITE(*, *) 'WARNING from getfilr'
358     WRITE(*, *) 'For key ', TRIM(MY_TARGET), &
359     & ' we have a compressed field but which does not have the right size.'
360     WRITE(*, *) 'We will try to fix that '
361     compressed = .TRUE.
362     compvalue = ret_val(it)
363     ENDIF
364     ENDIF
365     ELSE
366     found(it) = .FALSE.
367     ENDIF
368     ENDDO
369    
370     ! If this is a compressed field then we will uncompress it
371    
372     IF (compressed) THEN
373     DO it=1, nb_to_ret
374     IF (.NOT. found(it)) THEN
375     ret_val(it) = compvalue
376     found(it) = .TRUE.
377     ENDIF
378     ENDDO
379     ENDIF
380    
381     ! Now we get the status for what we found
382    
383     IF (def_beha) THEN
384     status = 2
385     WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)
386     ELSE
387     status_cnt = 0
388     DO it=1, nb_to_ret
389     IF (.NOT. found(it)) THEN
390     status_cnt = status_cnt+1
391     IF (nb_to_ret > 1) THEN
392     WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it
393     ELSE
394     str_tmp = TRIM(MY_TARGET)
395     ENDIF
396     WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)
397     ENDIF
398     ENDDO
399    
400     IF (status_cnt == 0) THEN
401     status = 1
402     ELSE IF (status_cnt == nb_to_ret) THEN
403     status = 2
404     ELSE
405     status = 3
406     ENDIF
407     ENDIF
408    
409     END SUBROUTINE getfili
410    
411     !****************************
412    
413     SUBROUTINE getfilc(MY_TARGET, status, fileorig, ret_val)
414    
415     ! Subroutine that will extract from the file the values
416     ! attributed to the keyword MY_TARGET
417    
418     ! CHARACTER
419     ! ---------
420    
421     ! MY_TARGET : in : CHARACTER(LEN=*) target for which we will
422     ! look in the file
423     ! status : out : INTEGER tells us from where we obtained the data
424     ! fileorig : out : The index of the file from which the key comes
425     ! ret_val : out : CHARACTER(nb_to_ret) values read
426    
427    
428     use strlowercase_m, only: strlowercase
429    
430     CHARACTER(LEN=*) :: MY_TARGET
431     INTEGER :: status, fileorig
432     CHARACTER(LEN=*), DIMENSION(:) :: ret_val
433    
434     INTEGER :: nb_to_ret
435     INTEGER :: it, pos, len_str, status_cnt
436     CHARACTER(LEN=3) :: cnt
437     CHARACTER(LEN=30) :: full_target
438     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
439     INTEGER :: full_target_sig
440    
441     INTEGER, SAVE :: max_len = 0
442     LOGICAL, DIMENSION(:), SAVE, ALLOCATABLE :: found
443     LOGICAL :: def_beha
444    
445     nb_to_ret = SIZE(ret_val)
446     CALL getin_read
447    
448     ! Get the variables and memory we need
449    
450     IF (max_len == 0) THEN
451     ALLOCATE(found(nb_to_ret))
452     max_len = nb_to_ret
453     ENDIF
454     IF (max_len < nb_to_ret) THEN
455     DEALLOCATE(found)
456     ALLOCATE(found(nb_to_ret))
457     max_len = nb_to_ret
458     ENDIF
459     found(:) = .FALSE.
460    
461     ! See what we find in the files read
462    
463     DO it=1, nb_to_ret
464    
465     ! First try the target as it is
466     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))
467     CALL gensig (full_target, full_target_sig)
468     CALL find_sig (nb_lines, targetlist, full_target, &
469     & targetsiglist, full_target_sig, pos)
470    
471     ! Another try
472    
473     IF (pos < 0) THEN
474     WRITE(cnt, '(I3.3)') it
475     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt
476     CALL gensig (full_target, full_target_sig)
477     CALL find_sig (nb_lines, targetlist, full_target, &
478     & targetsiglist, full_target_sig, pos)
479     ENDIF
480    
481     ! A priori we dont know from which file the target could come.
482     ! Thus by default we attribute it to the first file :
483    
484     fileorig = 1
485    
486     IF (pos > 0) THEN
487    
488     found(it) = .TRUE.
489     fileorig = fromfile(pos)
490    
491     ! DECODE
492    
493     str_READ = TRIM(ADJUSTL(fichier(pos)))
494     str_READ_lower = str_READ
495     CALL strlowercase (str_READ_lower)
496    
497     IF ( ( (INDEX(str_READ_lower, 'def') == 1) &
498     & .AND.(LEN_TRIM(str_READ_lower) == 3) ) &
499     & .OR.( (INDEX(str_READ_lower, 'default') == 1) &
500     & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN
501     def_beha = .TRUE.
502     ELSE
503     def_beha = .FALSE.
504     len_str = LEN_TRIM(str_READ)
505     ret_val(it) = str_READ(1:len_str)
506     ENDIF
507    
508     targetsiglist(pos) = -1
509    
510     ELSE
511     found(it) = .FALSE.
512     ENDIF
513     ENDDO
514    
515     ! Now we get the status for what we found
516    
517     IF (def_beha) THEN
518     status = 2
519     WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)
520     ELSE
521     status_cnt = 0
522     DO it=1, nb_to_ret
523     IF (.NOT. found(it)) THEN
524     status_cnt = status_cnt+1
525     IF (nb_to_ret > 1) THEN
526     WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it
527     ELSE
528     str_tmp = MY_TARGET(1:len_TRIM(MY_TARGET))
529     ENDIF
530     WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)
531     ENDIF
532     ENDDO
533    
534     IF (status_cnt == 0) THEN
535     status = 1
536     ELSE IF (status_cnt == nb_to_ret) THEN
537     status = 2
538     ELSE
539     status = 3
540     ENDIF
541     ENDIF
542    
543     END SUBROUTINE getfilc
544    
545     !****************************
546    
547     SUBROUTINE getfill(MY_TARGET, status, fileorig, ret_val)
548    
549     ! Subroutine that will extract from the file the values
550     ! attributed to the keyword MY_TARGET
551    
552     ! LOGICAL
553     ! -------
554    
555     ! MY_TARGET : in : CHARACTER(LEN=*) target for which we will
556     ! look in the file
557     ! status : out : INTEGER tells us from where we obtained the data
558     ! fileorig : out : The index of the file from which the key comes
559     ! ret_val : out : LOGICAL(nb_to_ret) values read
560    
561    
562     use strlowercase_m, only: strlowercase
563    
564     CHARACTER(LEN=*) :: MY_TARGET
565     INTEGER :: status, fileorig
566     LOGICAL, DIMENSION(:) :: ret_val
567    
568     INTEGER :: nb_to_ret
569     INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt
570     CHARACTER(LEN=3) :: cnt
571     CHARACTER(LEN=30) :: full_target
572     CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
573     INTEGER :: full_target_sig
574    
575     INTEGER, SAVE :: max_len = 0
576     LOGICAL, DIMENSION(:), SAVE, ALLOCATABLE :: found
577     LOGICAL :: def_beha
578    
579     nb_to_ret = SIZE(ret_val)
580     CALL getin_read
581    
582     ! Get the variables and memory we need
583    
584     IF (max_len == 0) THEN
585     ALLOCATE(found(nb_to_ret))
586     max_len = nb_to_ret
587     ENDIF
588     IF (max_len < nb_to_ret) THEN
589     DEALLOCATE(found)
590     ALLOCATE(found(nb_to_ret))
591     max_len = nb_to_ret
592     ENDIF
593     found(:) = .FALSE.
594    
595     ! See what we find in the files read
596    
597     DO it=1, nb_to_ret
598    
599     ! First try the target as it is
600    
601     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))
602     CALL gensig (full_target, full_target_sig)
603     CALL find_sig (nb_lines, targetlist, full_target, &
604     & targetsiglist, full_target_sig, pos)
605    
606     ! Another try
607    
608     IF (pos < 0) THEN
609     WRITE(cnt, '(I3.3)') it
610     full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt
611     CALL gensig (full_target, full_target_sig)
612     CALL find_sig (nb_lines, targetlist, full_target, &
613     & targetsiglist, full_target_sig, pos)
614     ENDIF
615    
616     ! A priori we dont know from which file the target could come.
617     ! Thus by default we attribute it to the first file :
618    
619     fileorig = 1
620    
621     IF (pos > 0) THEN
622    
623     found(it) = .TRUE.
624     fileorig = fromfile(pos)
625    
626     ! DECODE
627    
628     str_READ = TRIM(ADJUSTL(fichier(pos)))
629     str_READ_lower = str_READ
630     CALL strlowercase (str_READ_lower)
631    
632     IF ( ( (INDEX(str_READ_lower, 'def') == 1) &
633     & .AND.(LEN_TRIM(str_READ_lower) == 3) ) &
634     & .OR.( (INDEX(str_READ_lower, 'default') == 1) &
635     & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN
636     def_beha = .TRUE.
637     ELSE
638     def_beha = .FALSE.
639     len_str = LEN_TRIM(str_READ)
640     ipos_tr = -1
641     ipos_fl = -1
642    
643     ipos_tr = MAX(INDEX(str_READ, 'tru'), INDEX(str_READ, 'TRU'), &
644     & INDEX(str_READ, 'y'), INDEX(str_READ, 'Y'))
645     ipos_fl = MAX(INDEX(str_READ, 'fal'), INDEX(str_READ, 'FAL'), &
646     & INDEX(str_READ, 'n'), INDEX(str_READ, 'N'))
647    
648     IF (ipos_tr > 0) THEN
649     ret_val(it) = .TRUE.
650     ELSE IF (ipos_fl > 0) THEN
651     ret_val(it) = .FALSE.
652     ELSE
653     WRITE(*, *) "ERROR : getfill : MY_TARGET ", &
654     & TRIM(MY_TARGET), " is not of logical value"
655     STOP 'getinl'
656     ENDIF
657     ENDIF
658    
659     targetsiglist(pos) = -1
660    
661     ELSE
662    
663     found(it) = .FALSE.
664    
665     ENDIF
666    
667     ENDDO
668    
669     ! Now we get the status for what we found
670    
671     IF (def_beha) THEN
672     status = 2
673     WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)
674     ELSE
675     status_cnt = 0
676     DO it=1, nb_to_ret
677     IF (.NOT. found(it)) THEN
678     status_cnt = status_cnt+1
679     IF (nb_to_ret > 1) THEN
680     WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it
681     ELSE
682     str_tmp = TRIM(MY_TARGET)
683     ENDIF
684     WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)
685     ENDIF
686     ENDDO
687    
688     IF (status_cnt == 0) THEN
689     status = 1
690     ELSE IF (status_cnt == nb_to_ret) THEN
691     status = 2
692     ELSE
693     status = 3
694     ENDIF
695     ENDIF
696    
697     END SUBROUTINE getfill
698    
699     !****************************
700    
701     SUBROUTINE getin_read
702    
703    
704     INTEGER, SAVE :: allread=0
705     INTEGER, SAVE :: current
706    
707     IF (allread == 0) THEN
708     ! Allocate a first set of memory.
709     CALL getin_allockeys
710     CALL getin_allocmem (1, 0)
711     CALL getin_allocmem (2, 0)
712     CALL getin_allocmem (3, 0)
713     CALL getin_allocmem (4, 0)
714     ! Start with reading the files
715     nbfiles = 1
716     filelist(1) = 'run.def'
717     current = 1
718     nb_lines = 0
719    
720     DO WHILE (current <= nbfiles)
721     CALL getin_readdef (current)
722     current = current+1
723     ENDDO
724     allread = 1
725     CALL getin_checkcohe ()
726     ENDIF
727    
728     END SUBROUTINE getin_read
729    
730     !****************************
731    
732     SUBROUTINE getin_readdef(current)
733    
734     ! This subroutine will read the files and only keep the
735     ! the relevant information. The information is kept as it
736     ! found in the file. The data will be analysed later.
737    
738     USE nocomma_m, ONLY : nocomma
739     use cmpblank_m, only: cmpblank
740    
741     INTEGER :: current
742    
743     CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str
744     CHARACTER(LEN=3) :: cnt
745     INTEGER :: nb_lastkey
746    
747     INTEGER :: eof, ptn, len_str, i, it, iund
748     LOGICAL :: check = .FALSE.
749    
750    
751    
752     eof = 0
753     ptn = 1
754     nb_lastkey = 0
755    
756     IF (check) THEN
757     WRITE(*, *) 'getin_readdef : Open file ', TRIM(filelist(current))
758     ENDIF
759    
760     OPEN (22, file=filelist(current), ERR=9997, STATUS="OLD")
761    
762     DO WHILE (eof /= 1)
763    
764     CALL getin_skipafew (22, READ_str, eof, nb_lastkey)
765     len_str = LEN_TRIM(READ_str)
766     ptn = INDEX(READ_str, '=')
767    
768     IF (ptn > 0) THEN
769     ! Get the target
770     key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
771     ! Make sure that if a vector keyword has the right length
772     iund = INDEX(key_str, '__')
773     IF (iund > 0) THEN
774     SELECT CASE( len_trim(key_str)-iund )
775     CASE(2)
776     READ(key_str(iund+2:len_trim(key_str)), '(I1)') it
777     CASE(3)
778     READ(key_str(iund+2:len_trim(key_str)), '(I2)') it
779     CASE(4)
780     READ(key_str(iund+2:len_trim(key_str)), '(I3)') it
781     CASE DEFAULT
782     it = -1
783     END SELECT
784     IF (it > 0) THEN
785     WRITE(cnt, '(I3.3)') it
786     key_str = key_str(1:iund+1)//cnt
787     ELSE
788     WRITE(*, *) &
789     & 'getin_readdef : A very strange key has just been found'
790     WRITE(*, *) 'getin_readdef : ', key_str(1:len_TRIM(key_str))
791     STOP 'getin_readdef'
792     ENDIF
793     ENDIF
794     ! Prepare the content
795     NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
796     CALL nocomma (NEW_str)
797     CALL cmpblank (NEW_str)
798     NEW_str = TRIM(ADJUSTL(NEW_str))
799     IF (check) THEN
800     WRITE(*, *) &
801     & '--> getin_readdef : ', TRIM(key_str), ' :: ', TRIM(NEW_str)
802     ENDIF
803     ! Decypher the content of NEW_str
804    
805     ! This has to be a new key word, thus :
806     nb_lastkey = 0
807    
808     CALL getin_decrypt (current, key_str, NEW_str, last_key, nb_lastkey)
809    
810     ELSE IF (len_str > 0) THEN
811     ! Prepare the key if we have an old one to which
812     ! we will add the line just read
813     IF (nb_lastkey > 0) THEN
814     iund = INDEX(last_key, '__')
815     IF (iund > 0) THEN
816     ! We only continue a keyword, thus it is easy
817     key_str = last_key(1:iund-1)
818     ELSE
819     IF (nb_lastkey /= 1) THEN
820     WRITE(*, *) &
821     & 'getin_readdef : An error has occured. We can not have a scalar'
822     WRITE(*, *) 'getin_readdef : keywod and a vector content'
823     STOP 'getin_readdef'
824     ENDIF
825     ! The last keyword needs to be transformed into a vector.
826     targetlist(nb_lines) = &
827     & last_key(1:MIN(len_trim(last_key), 30))//'__001'
828     CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
829     key_str = last_key(1:len_TRIM(last_key))
830     ENDIF
831     ENDIF
832     ! Prepare the content
833     NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
834     CALL getin_decrypt (current, key_str, NEW_str, last_key, nb_lastkey)
835     ELSE
836     ! If we have an empty line the the keyword finishes
837     nb_lastkey = 0
838     IF (check) THEN
839     WRITE(*, *) 'getin_readdef : Have found an emtpy line '
840     ENDIF
841     ENDIF
842     ENDDO
843    
844     CLOSE(22)
845    
846     IF (check) THEN
847     OPEN (22, file='run.def.test')
848     DO i=1, nb_lines
849     WRITE(22, *) targetlist(i), " : ", fichier(i)
850     ENDDO
851     CLOSE(22)
852     ENDIF
853    
854     RETURN
855    
856     9997 WRITE(*, *) "getin_readdef : Could not open file ", &
857     & TRIM(filelist(current))
858    
859     END SUBROUTINE getin_readdef
860    
861     !****************************
862    
863     SUBROUTINE getin_decrypt(current, key_str, NEW_str, last_key, nb_lastkey)
864    
865     ! This subroutine is going to decypher the line.
866     ! It essentialy checks how many items are included and
867     ! it they can be attached to a key.
868    
869    
870     ! ARGUMENTS
871    
872     INTEGER :: current, nb_lastkey
873     CHARACTER(LEN=*) :: key_str, NEW_str, last_key
874    
875     ! LOCAL
876    
877     INTEGER :: len_str, blk, nbve, starpos
878     CHARACTER(LEN=100) :: tmp_str, new_key, mult
879     CHARACTER(LEN=3) :: cnt, chlen
880     CHARACTER(LEN=10) :: fmt
881    
882     len_str = LEN_TRIM(NEW_str)
883     blk = INDEX(NEW_str(1:len_str), ' ')
884     tmp_str = NEW_str(1:len_str)
885    
886     ! If the key is a new file then we take it up. Else
887     ! we save the line and go on.
888    
889     IF (INDEX(key_str, 'INCLUDEDEF') > 0) THEN
890     DO WHILE (blk > 0)
891     IF (nbfiles+1 > max_files) THEN
892     WRITE(*, *) 'FATAL ERROR : Too many files to include'
893     STOP 'getin_readdef'
894     ENDIF
895    
896     nbfiles = nbfiles+1
897     filelist(nbfiles) = tmp_str(1:blk)
898    
899     tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
900     blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)), ' ')
901     ENDDO
902    
903     IF (nbfiles+1 > max_files) THEN
904     WRITE(*, *) 'FATAL ERROR : Too many files to include'
905     STOP 'getin_readdef'
906     ENDIF
907    
908     nbfiles = nbfiles+1
909     filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
910    
911     last_key = 'INCLUDEDEF'
912     nb_lastkey = 1
913     ELSE
914    
915     ! We are working on a new line of input
916    
917     nb_lines = nb_lines+1
918     IF (nb_lines > max_lines) THEN
919     WRITE(*, *) &
920     & 'Too many line in the run.def files. You need to increase'
921     WRITE(*, *) 'the parameter max_lines in the module getincom.'
922     STOP 'getin_decrypt'
923     ENDIF
924    
925     ! First we solve the issue of conpressed information. Once
926     ! this is done all line can be handled in the same way.
927    
928     starpos = INDEX(NEW_str(1:len_str), '*')
929     IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
930     & .AND.(tmp_str(1:1) /= "'") ) THEN
931    
932     IF (INDEX(key_str(1:len_TRIM(key_str)), '__') > 0) THEN
933     WRITE(*, *) 'ERROR : getin_decrypt'
934     WRITE(*, *) &
935     & 'We can not have a compressed field of values for in a'
936     WRITE(*, *) &
937     & 'vector notation. If a target is of the type TARGET__1'
938     WRITE(*, *) 'then only a scalar value is allowed'
939     WRITE(*, *) 'The key at fault : ', key_str(1:len_TRIM(key_str))
940     STOP 'getin_decrypt'
941     ENDIF
942    
943     ! Read the multiplied
944    
945     mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
946     ! Construct the new string and its parameters
947     NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
948     len_str = LEN_TRIM(NEW_str)
949     blk = INDEX(NEW_str(1:len_str), ' ')
950     IF (blk > 1) THEN
951     WRITE(*, *) &
952     & 'This is a strange behavior of getin_decrypt you could report'
953     ENDIF
954     WRITE(chlen, '(I3.3)') LEN_TRIM(mult)
955     fmt = '(I'//chlen//')'
956     READ(mult, fmt) compline(nb_lines)
957    
958     ELSE
959     compline(nb_lines) = -1
960     ENDIF
961    
962     ! If there is no space wthin the line then the target is a scalar
963     ! or the element of a properly written vector.
964     ! (ie of the type TARGET__1)
965    
966     IF ( (blk <= 1) &
967     & .OR.(tmp_str(1:1) == '"') &
968     & .OR.(tmp_str(1:1) == "'") ) THEN
969    
970     IF (nb_lastkey == 0) THEN
971     ! Save info of current keyword as a scalar
972     ! if it is not a continuation
973     targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str), 30))
974     last_key = key_str(1:MIN(len_trim(key_str), 30))
975     nb_lastkey = 1
976     ELSE
977     ! We are continuing a vector so the keyword needs
978     ! to get the underscores
979     WRITE(cnt, '(I3.3)') nb_lastkey+1
980     targetlist(nb_lines) = &
981     & key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
982     last_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
983     nb_lastkey = nb_lastkey+1
984     ENDIF
985    
986     CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
987     fichier(nb_lines) = NEW_str(1:len_str)
988     fromfile(nb_lines) = current
989     ELSE
990    
991     ! If there are blanks whithin the line then we are dealing
992     ! with a vector and we need to split it in many entries
993     ! with the TRAGET__1 notation.
994    
995     ! Test if the targer is not already a vector target !
996    
997     IF (INDEX(TRIM(key_str), '__') > 0) THEN
998     WRITE(*, *) 'ERROR : getin_decrypt'
999     WRITE(*, *) 'We have found a mixed vector notation'
1000     WRITE(*, *) 'If a target is of the type TARGET__1'
1001     WRITE(*, *) 'then only a scalar value is allowed'
1002     WRITE(*, *) 'The key at fault : ', key_str(1:len_TRIM(key_str))
1003     STOP 'getin_decrypt'
1004     ENDIF
1005    
1006     nbve = nb_lastkey
1007     nbve = nbve+1
1008     WRITE(cnt, '(I3.3)') nbve
1009    
1010     DO WHILE (blk > 0)
1011    
1012     ! Save the content of target__nbve
1013    
1014     fichier(nb_lines) = tmp_str(1:blk)
1015     new_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
1016     targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key), 30))
1017     CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
1018     fromfile(nb_lines) = current
1019    
1020     tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
1021     blk = INDEX(TRIM(tmp_str), ' ')
1022    
1023     nb_lines = nb_lines+1
1024     IF (nb_lines > max_lines) THEN
1025     WRITE(*, *) &
1026     & 'Too many line in the run.def files. You need to increase'
1027     WRITE(*, *) 'the parameter max_lines in the module getincom.'
1028     STOP 'getin_decrypt'
1029     ENDIF
1030     nbve = nbve+1
1031     WRITE(cnt, '(I3.3)') nbve
1032    
1033     ENDDO
1034    
1035     ! Save the content of the last target
1036    
1037     fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
1038     new_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
1039     targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key), 30))
1040     CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
1041     fromfile(nb_lines) = current
1042    
1043     last_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
1044     nb_lastkey = nbve
1045    
1046     ENDIF
1047    
1048     ENDIF
1049    
1050     END SUBROUTINE getin_decrypt
1051    
1052     !****************************
1053    
1054     SUBROUTINE getin_checkcohe ()
1055    
1056     ! This subroutine checks for redundancies.
1057    
1058    
1059     ! Arguments
1060    
1061    
1062     ! LOCAL
1063    
1064     INTEGER :: line, i, sig
1065     INTEGER :: found
1066     CHARACTER(LEN=30) :: str
1067    
1068     DO line=1, nb_lines-1
1069    
1070     CALL find_sig &
1071     & (nb_lines-line, targetlist(line+1:nb_lines), targetlist(line), &
1072     & targetsiglist(line+1:nb_lines), targetsiglist(line), found)
1073    
1074     ! IF we have found it we have a problem to solve.
1075    
1076     IF (found > 0) THEN
1077     WRITE(*, *) 'COUNT : ', &
1078     & COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1)
1079    
1080     WRITE(*, *) &
1081     & 'getin_checkcohe : Found a problem on key ', targetlist(line)
1082     WRITE(*, *) &
1083     & 'getin_checkcohe : The following values were encoutered :'
1084     WRITE(*, *) &
1085     & ' ', TRIM(targetlist(line)), &
1086     & targetsiglist(line), ' == ', fichier(line)
1087     WRITE(*, *) &
1088     & ' ', TRIM(targetlist(line+found)), &
1089     & targetsiglist(line+found), ' == ', fichier(line+found)
1090     WRITE(*, *) &
1091     & 'getin_checkcohe : We will keep only the last value'
1092    
1093     targetsiglist(line) = 1
1094     ENDIF
1095     ENDDO
1096    
1097     END SUBROUTINE getin_checkcohe
1098    
1099     !****************************
1100    
1101     SUBROUTINE getin_skipafew (unit, out_string, eof, nb_lastkey)
1102    
1103    
1104     INTEGER :: unit, eof, nb_lastkey
1105     CHARACTER(LEN=100) :: dummy
1106     CHARACTER(LEN=100) :: out_string
1107     CHARACTER(LEN=1) :: first
1108    
1109     first="#"
1110     eof = 0
1111     out_string = " "
1112    
1113     DO WHILE (first == "#")
1114     READ (unit, '(a100)', ERR=9998, END=7778) dummy
1115     dummy = TRIM(ADJUSTL(dummy))
1116     first=dummy(1:1)
1117     IF (first == "#") THEN
1118     nb_lastkey = 0
1119     ENDIF
1120     ENDDO
1121     out_string=dummy
1122    
1123     RETURN
1124    
1125     9998 WRITE(*, *) " GETIN_SKIPAFEW : Error while reading file "
1126     STOP 'getin_skipafew'
1127    
1128     7778 eof = 1
1129    
1130     END SUBROUTINE getin_skipafew
1131    
1132     !=== INTEGER database INTERFACE
1133    
1134     SUBROUTINE getdbwi &
1135     & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1136    
1137     ! Write the INTEGER data into the data base
1138    
1139    
1140     CHARACTER(LEN=*) :: MY_TARGET
1141     INTEGER :: target_sig, status, fileorig, size_of_in
1142     INTEGER, DIMENSION(:) :: tmp_ret_val
1143    
1144    
1145     ! First check if we have sufficiant space for the new key
1146    
1147     IF (nb_keys+1 > keymemsize) THEN
1148     CALL getin_allockeys ()
1149     ENDIF
1150    
1151     ! Fill out the items of the data base
1152    
1153     nb_keys = nb_keys+1
1154     keysig(nb_keys) = target_sig
1155     keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1156     keystatus(nb_keys) = status
1157     keytype(nb_keys) = 1
1158     keyfromfile(nb_keys) = fileorig
1159    
1160     ! Can we compress the data base entry ?
1161    
1162     IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1163     & .AND.(size_of_in > compress_lim)) THEN
1164     keymemstart(nb_keys) = intmempos+1
1165     keycompress(nb_keys) = size_of_in
1166     keymemlen(nb_keys) = 1
1167     ELSE
1168     keymemstart(nb_keys) = intmempos+1
1169     keycompress(nb_keys) = -1
1170     keymemlen(nb_keys) = size_of_in
1171     ENDIF
1172    
1173     ! Before writing the actual size lets see if we have the space
1174    
1175     IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN
1176     CALL getin_allocmem (1, keymemlen(nb_keys))
1177     ENDIF
1178    
1179     intmem(keymemstart(nb_keys): &
1180     & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1181     & tmp_ret_val(1:keymemlen(nb_keys))
1182     intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1183    
1184     END SUBROUTINE getdbwi
1185    
1186     !****************************
1187    
1188     SUBROUTINE getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val)
1189    
1190     ! Read the required variables in the database for INTEGERS
1191    
1192    
1193     INTEGER :: pos, size_of_in
1194     CHARACTER(LEN=*) :: MY_TARGET
1195     INTEGER, DIMENSION(:) :: tmp_ret_val
1196    
1197     IF (keytype(pos) /= 1) THEN
1198     WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1199     STOP 'getdbri'
1200     ENDIF
1201    
1202     IF (keycompress(pos) > 0) THEN
1203     IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN
1204     WRITE(*, *) &
1205     & 'FATAL ERROR : Wrong compression length for keyword ', MY_TARGET
1206     STOP 'getdbri'
1207     ELSE
1208     tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos))
1209     ENDIF
1210     ELSE
1211     IF (keymemlen(pos) /= size_of_in) THEN
1212     WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1213     STOP 'getdbri'
1214     ELSE
1215     tmp_ret_val(1:size_of_in) = &
1216     & intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1217     ENDIF
1218     ENDIF
1219    
1220     END SUBROUTINE getdbri
1221    
1222     !=== REAL database INTERFACE
1223    
1224     SUBROUTINE getdbwr &
1225     & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1226    
1227     ! Write the REAL data into the data base
1228    
1229    
1230     CHARACTER(LEN=*) :: MY_TARGET
1231     INTEGER :: target_sig, status, fileorig, size_of_in
1232     REAL, DIMENSION(:) :: tmp_ret_val
1233    
1234    
1235     ! First check if we have sufficiant space for the new key
1236    
1237     IF (nb_keys+1 > keymemsize) THEN
1238     CALL getin_allockeys ()
1239     ENDIF
1240    
1241     ! Fill out the items of the data base
1242    
1243     nb_keys = nb_keys+1
1244     keysig(nb_keys) = target_sig
1245     keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1246     keystatus(nb_keys) = status
1247     keytype(nb_keys) = 2
1248     keyfromfile(nb_keys) = fileorig
1249    
1250     ! Can we compress the data base entry ?
1251    
1252     IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1253     & .AND.(size_of_in > compress_lim)) THEN
1254     keymemstart(nb_keys) = realmempos+1
1255     keycompress(nb_keys) = size_of_in
1256     keymemlen(nb_keys) = 1
1257     ELSE
1258     keymemstart(nb_keys) = realmempos+1
1259     keycompress(nb_keys) = -1
1260     keymemlen(nb_keys) = size_of_in
1261     ENDIF
1262    
1263     ! Before writing the actual size lets see if we have the space
1264    
1265     IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
1266     CALL getin_allocmem (2, keymemlen(nb_keys))
1267     ENDIF
1268    
1269     realmem(keymemstart(nb_keys): &
1270     & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1271     & tmp_ret_val(1:keymemlen(nb_keys))
1272     realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1273    
1274     END SUBROUTINE getdbwr
1275    
1276     !****************************
1277    
1278     SUBROUTINE getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val)
1279    
1280     ! Read the required variables in the database for REALS
1281    
1282    
1283     INTEGER :: pos, size_of_in
1284     CHARACTER(LEN=*) :: MY_TARGET
1285     REAL, DIMENSION(:) :: tmp_ret_val
1286    
1287     IF (keytype(pos) /= 2) THEN
1288     WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1289     STOP 'getdbrr'
1290     ENDIF
1291    
1292     IF (keycompress(pos) > 0) THEN
1293     IF ( (keycompress(pos) /= size_of_in) &
1294     & .OR.(keymemlen(pos) /= 1) ) THEN
1295     WRITE(*, *) &
1296     & 'FATAL ERROR : Wrong compression length for keyword ', MY_TARGET
1297     STOP 'getdbrr'
1298     ELSE
1299     tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos))
1300     ENDIF
1301     ELSE
1302     IF (keymemlen(pos) /= size_of_in) THEN
1303     WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1304     STOP 'getdbrr'
1305     ELSE
1306     tmp_ret_val(1:size_of_in) = &
1307     & realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1308     ENDIF
1309     ENDIF
1310    
1311     END SUBROUTINE getdbrr
1312    
1313     !=== CHARACTER database INTERFACE
1314    
1315     SUBROUTINE getdbwc &
1316     & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1317    
1318     ! Write the CHARACTER data into the data base
1319    
1320    
1321     CHARACTER(LEN=*) :: MY_TARGET
1322     INTEGER :: target_sig, status, fileorig, size_of_in
1323     CHARACTER(LEN=*), DIMENSION(:) :: tmp_ret_val
1324    
1325    
1326     ! First check if we have sufficiant space for the new key
1327    
1328     IF (nb_keys+1 > keymemsize) THEN
1329     CALL getin_allockeys ()
1330     ENDIF
1331    
1332     ! Fill out the items of the data base
1333    
1334     nb_keys = nb_keys+1
1335     keysig(nb_keys) = target_sig
1336     keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1337     keystatus(nb_keys) = status
1338     keytype(nb_keys) = 3
1339     keyfromfile(nb_keys) = fileorig
1340     keymemstart(nb_keys) = charmempos+1
1341     keymemlen(nb_keys) = size_of_in
1342    
1343     ! Before writing the actual size lets see if we have the space
1344    
1345     IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
1346     CALL getin_allocmem (3, keymemlen(nb_keys))
1347     ENDIF
1348    
1349     charmem(keymemstart(nb_keys): &
1350     & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1351     & tmp_ret_val(1:keymemlen(nb_keys))
1352     charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1353    
1354     END SUBROUTINE getdbwc
1355    
1356     !****************************
1357    
1358     SUBROUTINE getdbrc(pos, size_of_in, MY_TARGET, tmp_ret_val)
1359    
1360     ! Read the required variables in the database for CHARACTER
1361    
1362    
1363     INTEGER :: pos, size_of_in
1364     CHARACTER(LEN=*) :: MY_TARGET
1365     CHARACTER(LEN=*), DIMENSION(:) :: tmp_ret_val
1366    
1367     IF (keytype(pos) /= 3) THEN
1368     WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1369     STOP 'getdbrc'
1370     ENDIF
1371    
1372     IF (keymemlen(pos) /= size_of_in) THEN
1373     WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1374     STOP 'getdbrc'
1375     ELSE
1376     tmp_ret_val(1:size_of_in) = &
1377     & charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1378     ENDIF
1379    
1380     END SUBROUTINE getdbrc
1381    
1382     !=== LOGICAL database INTERFACE
1383    
1384     SUBROUTINE getdbwl &
1385     & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1386    
1387     ! Write the LOGICAL data into the data base
1388    
1389    
1390     CHARACTER(LEN=*) :: MY_TARGET
1391     INTEGER :: target_sig, status, fileorig, size_of_in
1392     LOGICAL, DIMENSION(:) :: tmp_ret_val
1393    
1394    
1395     ! First check if we have sufficiant space for the new key
1396    
1397     IF (nb_keys+1 > keymemsize) THEN
1398     CALL getin_allockeys ()
1399     ENDIF
1400    
1401     ! Fill out the items of the data base
1402    
1403     nb_keys = nb_keys+1
1404     keysig(nb_keys) = target_sig
1405     keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1406     keystatus(nb_keys) = status
1407     keytype(nb_keys) = 4
1408     keyfromfile(nb_keys) = fileorig
1409     keymemstart(nb_keys) = logicmempos+1
1410     keymemlen(nb_keys) = size_of_in
1411    
1412     ! Before writing the actual size lets see if we have the space
1413    
1414     IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN
1415     CALL getin_allocmem (4, keymemlen(nb_keys))
1416     ENDIF
1417    
1418     logicmem(keymemstart(nb_keys): &
1419     & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1420     & tmp_ret_val(1:keymemlen(nb_keys))
1421     logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1422    
1423     END SUBROUTINE getdbwl
1424    
1425     !****************************
1426    
1427     SUBROUTINE getdbrl(pos, size_of_in, MY_TARGET, tmp_ret_val)
1428    
1429     ! Read the required variables in the database for LOGICALS
1430    
1431    
1432     INTEGER :: pos, size_of_in
1433     CHARACTER(LEN=*) :: MY_TARGET
1434     LOGICAL, DIMENSION(:) :: tmp_ret_val
1435    
1436     IF (keytype(pos) /= 4) THEN
1437     WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1438     STOP 'getdbrl'
1439     ENDIF
1440    
1441     IF (keymemlen(pos) /= size_of_in) THEN
1442     WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1443     STOP 'getdbrl'
1444     ELSE
1445     tmp_ret_val(1:size_of_in) = &
1446     & logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1447     ENDIF
1448    
1449     END SUBROUTINE getdbrl
1450    
1451     !****************************
1452    
1453     SUBROUTINE getin_allockeys
1454    
1455     INTEGER, ALLOCATABLE :: tmp_int(:)
1456     CHARACTER(LEN=100), ALLOCATABLE :: tmp_str(:)
1457    
1458    
1459    
1460     !!print *, "Call sequence information: getin_allockeys"
1461     ! Either nothing exists in these arrays and it is easy to do
1462    
1463     IF (keymemsize == 0) THEN
1464     ALLOCATE(keysig(memslabs))
1465     ALLOCATE(keystr(memslabs))
1466     ALLOCATE(keystatus(memslabs))
1467     ALLOCATE(keytype(memslabs))
1468     ALLOCATE(keycompress(memslabs))
1469     ALLOCATE(keyfromfile(memslabs))
1470     ALLOCATE(keymemstart(memslabs))
1471     ALLOCATE(keymemlen(memslabs))
1472     nb_keys = 0
1473     keymemsize = memslabs
1474     keycompress(:) = -1
1475     ELSE
1476     ! There is something already in the memory,
1477     ! we need to transfer and reallocate.
1478     ALLOCATE(tmp_str(keymemsize))
1479    
1480     ALLOCATE(tmp_int(keymemsize))
1481     tmp_int(1:keymemsize) = keysig(1:keymemsize)
1482    
1483     DEALLOCATE(keysig)
1484     ALLOCATE(keysig(keymemsize+memslabs))
1485     keysig(1:keymemsize) = tmp_int(1:keymemsize)
1486    
1487     tmp_str(1:keymemsize) = keystr(1:keymemsize)
1488     DEALLOCATE(keystr)
1489     ALLOCATE(keystr(keymemsize+memslabs))
1490     keystr(1:keymemsize) = tmp_str(1:keymemsize)
1491    
1492     tmp_int(1:keymemsize) = keystatus(1:keymemsize)
1493     DEALLOCATE(keystatus)
1494     ALLOCATE(keystatus(keymemsize+memslabs))
1495     keystatus(1:keymemsize) = tmp_int(1:keymemsize)
1496    
1497     tmp_int(1:keymemsize) = keytype(1:keymemsize)
1498     DEALLOCATE(keytype)
1499     ALLOCATE(keytype(keymemsize+memslabs))
1500     keytype(1:keymemsize) = tmp_int(1:keymemsize)
1501    
1502     tmp_int(1:keymemsize) = keycompress(1:keymemsize)
1503     DEALLOCATE(keycompress)
1504     ALLOCATE(keycompress(keymemsize+memslabs))
1505     keycompress(:) = -1
1506     keycompress(1:keymemsize) = tmp_int(1:keymemsize)
1507    
1508     tmp_int(1:keymemsize) = keyfromfile(1:keymemsize)
1509     DEALLOCATE(keyfromfile)
1510     ALLOCATE(keyfromfile(keymemsize+memslabs))
1511     keyfromfile(1:keymemsize) = tmp_int(1:keymemsize)
1512    
1513     tmp_int(1:keymemsize) = keymemstart(1:keymemsize)
1514     DEALLOCATE(keymemstart)
1515     ALLOCATE(keymemstart(keymemsize+memslabs))
1516     keymemstart(1:keymemsize) = tmp_int(1:keymemsize)
1517    
1518     tmp_int(1:keymemsize) = keymemlen(1:keymemsize)
1519     DEALLOCATE(keymemlen)
1520     ALLOCATE(keymemlen(keymemsize+memslabs))
1521     keymemlen(1:keymemsize) = tmp_int(1:keymemsize)
1522    
1523     keymemsize = keymemsize+memslabs
1524    
1525     DEALLOCATE(tmp_int)
1526     DEALLOCATE(tmp_str)
1527     ENDIF
1528    
1529     END SUBROUTINE getin_allockeys
1530    
1531     !****************************
1532    
1533     SUBROUTINE getin_allocmem (type, len_wanted)
1534    
1535     ! Allocate the memory of the data base for all 4 types of memory
1536    
1537     ! 1 = INTEGER
1538     ! 2 = REAL
1539     ! 3 = CHAR
1540     ! 4 = LOGICAL
1541    
1542    
1543     INTEGER :: type, len_wanted
1544    
1545     INTEGER, ALLOCATABLE :: tmp_int(:)
1546     CHARACTER(LEN=100), ALLOCATABLE :: tmp_char(:)
1547     REAL, ALLOCATABLE :: tmp_real(:)
1548     LOGICAL, ALLOCATABLE :: tmp_logic(:)
1549     INTEGER :: ier
1550    
1551     SELECT CASE (type)
1552     CASE(1)
1553     IF (intmemsize == 0) THEN
1554     ALLOCATE(intmem(memslabs), stat=ier)
1555     IF (ier /= 0) THEN
1556     WRITE(*, *) &
1557     & 'getin_allocmem : Unable to allocate db-memory intmem to ', &
1558     & memslabs
1559     STOP
1560     ENDIF
1561     intmemsize=memslabs
1562     ELSE
1563     ALLOCATE(tmp_int(intmemsize), stat=ier)
1564     IF (ier /= 0) THEN
1565     WRITE(*, *) &
1566     & 'getin_allocmem : Unable to allocate tmp_int to ', &
1567     & intmemsize
1568     STOP
1569     ENDIF
1570     tmp_int(1:intmemsize) = intmem(1:intmemsize)
1571     DEALLOCATE(intmem)
1572     ALLOCATE(intmem(intmemsize+MAX(memslabs, len_wanted)), stat=ier)
1573     IF (ier /= 0) THEN
1574     WRITE(*, *) &
1575     & 'getin_allocmem : Unable to re-allocate db-memory intmem to ', &
1576     & intmemsize+MAX(memslabs, len_wanted)
1577     STOP
1578     ENDIF
1579     intmem(1:intmemsize) = tmp_int(1:intmemsize)
1580     intmemsize = intmemsize+MAX(memslabs, len_wanted)
1581     DEALLOCATE(tmp_int)
1582     ENDIF
1583     CASE(2)
1584     IF (realmemsize == 0) THEN
1585     ALLOCATE(realmem(memslabs), stat=ier)
1586     IF (ier /= 0) THEN
1587     WRITE(*, *) &
1588     & 'getin_allocmem : Unable to allocate db-memory realmem to ', &
1589     & memslabs
1590     STOP
1591     ENDIF
1592     realmemsize = memslabs
1593     ELSE
1594     ALLOCATE(tmp_real(realmemsize), stat=ier)
1595     IF (ier /= 0) THEN
1596     WRITE(*, *) &
1597     & 'getin_allocmem : Unable to allocate tmp_real to ', &
1598     & realmemsize
1599     STOP
1600     ENDIF
1601     tmp_real(1:realmemsize) = realmem(1:realmemsize)
1602     DEALLOCATE(realmem)
1603     ALLOCATE(realmem(realmemsize+MAX(memslabs, len_wanted)), stat=ier)
1604     IF (ier /= 0) THEN
1605     WRITE(*, *) &
1606     & 'getin_allocmem : Unable to re-allocate db-memory realmem to ', &
1607     & realmemsize+MAX(memslabs, len_wanted)
1608     STOP
1609     ENDIF
1610     realmem(1:realmemsize) = tmp_real(1:realmemsize)
1611     realmemsize = realmemsize+MAX(memslabs, len_wanted)
1612     DEALLOCATE(tmp_real)
1613     ENDIF
1614     CASE(3)
1615     IF (charmemsize == 0) THEN
1616     ALLOCATE(charmem(memslabs), stat=ier)
1617     IF (ier /= 0) THEN
1618     WRITE(*, *) &
1619     & 'getin_allocmem : Unable to allocate db-memory charmem to ', &
1620     & memslabs
1621     STOP
1622     ENDIF
1623     charmemsize = memslabs
1624     ELSE
1625     ALLOCATE(tmp_char(charmemsize), stat=ier)
1626     IF (ier /= 0) THEN
1627     WRITE(*, *) &
1628     & 'getin_allocmem : Unable to allocate tmp_char to ', &
1629     & charmemsize
1630     STOP
1631     ENDIF
1632     tmp_char(1:charmemsize) = charmem(1:charmemsize)
1633     DEALLOCATE(charmem)
1634     ALLOCATE(charmem(charmemsize+MAX(memslabs, len_wanted)), stat=ier)
1635     IF (ier /= 0) THEN
1636     WRITE(*, *) &
1637     & 'getin_allocmem : Unable to re-allocate db-memory charmem to ', &
1638     & charmemsize+MAX(memslabs, len_wanted)
1639     STOP
1640     ENDIF
1641     charmem(1:charmemsize) = tmp_char(1:charmemsize)
1642     charmemsize = charmemsize+MAX(memslabs, len_wanted)
1643     DEALLOCATE(tmp_char)
1644     ENDIF
1645     CASE(4)
1646     IF (logicmemsize == 0) THEN
1647     ALLOCATE(logicmem(memslabs), stat=ier)
1648     IF (ier /= 0) THEN
1649     WRITE(*, *) &
1650     & 'getin_allocmem : Unable to allocate db-memory logicmem to ', &
1651     & memslabs
1652     STOP
1653     ENDIF
1654     logicmemsize = memslabs
1655     ELSE
1656     ALLOCATE(tmp_logic(logicmemsize), stat=ier)
1657     IF (ier /= 0) THEN
1658     WRITE(*, *) &
1659     & 'getin_allocmem : Unable to allocate tmp_logic to ', &
1660     & logicmemsize
1661     STOP
1662     ENDIF
1663     tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize)
1664     DEALLOCATE(logicmem)
1665     ALLOCATE(logicmem(logicmemsize+MAX(memslabs, len_wanted)), stat=ier)
1666     IF (ier /= 0) THEN
1667     WRITE(*, *) &
1668     & 'getin_allocmem : Unable to re-allocate db-memory logicmem to ', &
1669     & logicmemsize+MAX(memslabs, len_wanted)
1670     STOP
1671     ENDIF
1672     logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize)
1673     logicmemsize = logicmemsize+MAX(memslabs, len_wanted)
1674     DEALLOCATE(tmp_logic)
1675     ENDIF
1676     CASE DEFAULT
1677     WRITE(*, *) 'getin_allocmem : Unknown type : ', type
1678     STOP
1679     END SELECT
1680    
1681     END SUBROUTINE getin_allocmem
1682    
1683     END MODULE getincom2
  ViewVC Help
Powered by ViewVC 1.1.21