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

Contents of /trunk/libf/IOIPSL/getincom2.f90

Parent Directory Parent Directory | Revision Log Revision Log

Revision 51 - (show annotations)
Tue Sep 20 09:14:34 2011 UTC (12 years, 8 months ago) by guez
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 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