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

Contents of /trunk/IOIPSL/getincom2.f90

Parent Directory Parent Directory | Revision Log Revision Log

Revision 72 - (show annotations)
Tue Jul 23 13:00:07 2013 UTC (10 years, 10 months ago) by guez
Original Path: trunk/libf/IOIPSL/getincom2.f90
File size: 45981 byte(s) 
NaN to signalling NaN in gfortran_debug.mk.

Removed unused procedures in getincom and getincom2. In procedure
conf_interface, replaced call to getincom by new namelist. Moved
procedure conf_interface into module interface_surf.

Added variables sig1 and w01 to startphy.nc and restartphy.nc, for
procedure cv_driver. Renamed (ema_)?work1 and (ema_)?work2 to sig1 and
w01 in concvl and physiq.

Deleted unused arguments of clmain, clqh and intersurf_hq, among which
(y)?sollwdown. Following LMDZ, in physiq, read sollw instead of
sollwdown from startphy.nc, write sollw instead of sollwdown to
restartphy.nc.

In procedure sw, initialized zfs[ud][pn]a[di], for runs where ok_ade
and ok_aie are false. (Following LMDZ.)

Added dimension klev to startphy.nc and restartphy.nc, and deleted
dimension horizon_vertical. Made t_ancien and q_ancien two-dimensional
NetCDF variables. Bug fix: in phyetat0, define ratqs, clwcon and
rnebcon for vertical levels >=2.

Bug fix: set mfg, p[de]n_[ud] to 0. when iflag_con >= 3. (Following LMDZ.)
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 getfill(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 ! LOGICAL
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 : LOGICAL(nb_to_ret) values read
426
427
428 use strlowercase_m, only: strlowercase
429
430 CHARACTER(LEN=*) :: MY_TARGET
431 INTEGER :: status, fileorig
432 LOGICAL, DIMENSION(:) :: ret_val
433
434 INTEGER :: nb_to_ret
435 INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, 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
467 full_target = MY_TARGET(1:len_TRIM(MY_TARGET))
468 CALL gensig (full_target, full_target_sig)
469 CALL find_sig (nb_lines, targetlist, full_target, &
470 & targetsiglist, full_target_sig, pos)
471
472 ! Another try
473
474 IF (pos < 0) THEN
475 WRITE(cnt, '(I3.3)') it
476 full_target = MY_TARGET(1:len_TRIM(MY_TARGET))//'__'//cnt
477 CALL gensig (full_target, full_target_sig)
478 CALL find_sig (nb_lines, targetlist, full_target, &
479 & targetsiglist, full_target_sig, pos)
480 ENDIF
481
482 ! A priori we dont know from which file the target could come.
483 ! Thus by default we attribute it to the first file :
484
485 fileorig = 1
486
487 IF (pos > 0) THEN
488
489 found(it) = .TRUE.
490 fileorig = fromfile(pos)
491
492 ! DECODE
493
494 str_READ = TRIM(ADJUSTL(fichier(pos)))
495 str_READ_lower = str_READ
496 CALL strlowercase (str_READ_lower)
497
498 IF ( ( (INDEX(str_READ_lower, 'def') == 1) &
499 & .AND.(LEN_TRIM(str_READ_lower) == 3) ) &
500 & .OR.( (INDEX(str_READ_lower, 'default') == 1) &
501 & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN
502 def_beha = .TRUE.
503 ELSE
504 def_beha = .FALSE.
505 len_str = LEN_TRIM(str_READ)
506 ipos_tr = -1
507 ipos_fl = -1
508
509 ipos_tr = MAX(INDEX(str_READ, 'tru'), INDEX(str_READ, 'TRU'), &
510 & INDEX(str_READ, 'y'), INDEX(str_READ, 'Y'))
511 ipos_fl = MAX(INDEX(str_READ, 'fal'), INDEX(str_READ, 'FAL'), &
512 & INDEX(str_READ, 'n'), INDEX(str_READ, 'N'))
513
514 IF (ipos_tr > 0) THEN
515 ret_val(it) = .TRUE.
516 ELSE IF (ipos_fl > 0) THEN
517 ret_val(it) = .FALSE.
518 ELSE
519 WRITE(*, *) "ERROR : getfill : MY_TARGET ", &
520 & TRIM(MY_TARGET), " is not of logical value"
521 STOP 'getinl'
522 ENDIF
523 ENDIF
524
525 targetsiglist(pos) = -1
526
527 ELSE
528
529 found(it) = .FALSE.
530
531 ENDIF
532
533 ENDDO
534
535 ! Now we get the status for what we found
536
537 IF (def_beha) THEN
538 status = 2
539 WRITE(*, *) 'USING DEFAULT BEHAVIOUR FOR ', TRIM(MY_TARGET)
540 ELSE
541 status_cnt = 0
542 DO it=1, nb_to_ret
543 IF (.NOT. found(it)) THEN
544 status_cnt = status_cnt+1
545 IF (nb_to_ret > 1) THEN
546 WRITE(str_tmp, '(a, "__", I3.3)') TRIM(MY_TARGET), it
547 ELSE
548 str_tmp = TRIM(MY_TARGET)
549 ENDIF
550 WRITE(*, *) 'USING DEFAULTS : ', TRIM(str_tmp), '=', ret_val(it)
551 ENDIF
552 ENDDO
553
554 IF (status_cnt == 0) THEN
555 status = 1
556 ELSE IF (status_cnt == nb_to_ret) THEN
557 status = 2
558 ELSE
559 status = 3
560 ENDIF
561 ENDIF
562
563 END SUBROUTINE getfill
564
565 !****************************
566
567 SUBROUTINE getin_read
568
569
570 INTEGER, SAVE :: allread=0
571 INTEGER, SAVE :: current
572
573 IF (allread == 0) THEN
574 ! Allocate a first set of memory.
575 CALL getin_allockeys
576 CALL getin_allocmem (1, 0)
577 CALL getin_allocmem (2, 0)
578 CALL getin_allocmem (3, 0)
579 CALL getin_allocmem (4, 0)
580 ! Start with reading the files
581 nbfiles = 1
582 filelist(1) = 'run.def'
583 current = 1
584 nb_lines = 0
585
586 DO WHILE (current <= nbfiles)
587 CALL getin_readdef (current)
588 current = current+1
589 ENDDO
590 allread = 1
591 CALL getin_checkcohe ()
592 ENDIF
593
594 END SUBROUTINE getin_read
595
596 !****************************
597
598 SUBROUTINE getin_readdef(current)
599
600 ! This subroutine will read the files and only keep the
601 ! the relevant information. The information is kept as it
602 ! found in the file. The data will be analysed later.
603
604 USE nocomma_m, ONLY : nocomma
605 use cmpblank_m, only: cmpblank
606
607 INTEGER :: current
608
609 CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str
610 CHARACTER(LEN=3) :: cnt
611 INTEGER :: nb_lastkey
612
613 INTEGER :: eof, ptn, len_str, i, it, iund
614 LOGICAL :: check = .FALSE.
615
616
617
618 eof = 0
619 ptn = 1
620 nb_lastkey = 0
621
622 IF (check) THEN
623 WRITE(*, *) 'getin_readdef : Open file ', TRIM(filelist(current))
624 ENDIF
625
626 OPEN (22, file=filelist(current), ERR=9997, STATUS="OLD")
627
628 DO WHILE (eof /= 1)
629
630 CALL getin_skipafew (22, READ_str, eof, nb_lastkey)
631 len_str = LEN_TRIM(READ_str)
632 ptn = INDEX(READ_str, '=')
633
634 IF (ptn > 0) THEN
635 ! Get the target
636 key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
637 ! Make sure that if a vector keyword has the right length
638 iund = INDEX(key_str, '__')
639 IF (iund > 0) THEN
640 SELECT CASE( len_trim(key_str)-iund )
641 CASE(2)
642 READ(key_str(iund+2:len_trim(key_str)), '(I1)') it
643 CASE(3)
644 READ(key_str(iund+2:len_trim(key_str)), '(I2)') it
645 CASE(4)
646 READ(key_str(iund+2:len_trim(key_str)), '(I3)') it
647 CASE DEFAULT
648 it = -1
649 END SELECT
650 IF (it > 0) THEN
651 WRITE(cnt, '(I3.3)') it
652 key_str = key_str(1:iund+1)//cnt
653 ELSE
654 WRITE(*, *) &
655 & 'getin_readdef : A very strange key has just been found'
656 WRITE(*, *) 'getin_readdef : ', key_str(1:len_TRIM(key_str))
657 STOP 'getin_readdef'
658 ENDIF
659 ENDIF
660 ! Prepare the content
661 NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
662 CALL nocomma (NEW_str)
663 CALL cmpblank (NEW_str)
664 NEW_str = TRIM(ADJUSTL(NEW_str))
665 IF (check) THEN
666 WRITE(*, *) &
667 & '--> getin_readdef : ', TRIM(key_str), ' :: ', TRIM(NEW_str)
668 ENDIF
669 ! Decypher the content of NEW_str
670
671 ! This has to be a new key word, thus :
672 nb_lastkey = 0
673
674 CALL getin_decrypt (current, key_str, NEW_str, last_key, nb_lastkey)
675
676 ELSE IF (len_str > 0) THEN
677 ! Prepare the key if we have an old one to which
678 ! we will add the line just read
679 IF (nb_lastkey > 0) THEN
680 iund = INDEX(last_key, '__')
681 IF (iund > 0) THEN
682 ! We only continue a keyword, thus it is easy
683 key_str = last_key(1:iund-1)
684 ELSE
685 IF (nb_lastkey /= 1) THEN
686 WRITE(*, *) &
687 & 'getin_readdef : An error has occured. We can not have a scalar'
688 WRITE(*, *) 'getin_readdef : keywod and a vector content'
689 STOP 'getin_readdef'
690 ENDIF
691 ! The last keyword needs to be transformed into a vector.
692 targetlist(nb_lines) = &
693 & last_key(1:MIN(len_trim(last_key), 30))//'__001'
694 CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
695 key_str = last_key(1:len_TRIM(last_key))
696 ENDIF
697 ENDIF
698 ! Prepare the content
699 NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
700 CALL getin_decrypt (current, key_str, NEW_str, last_key, nb_lastkey)
701 ELSE
702 ! If we have an empty line the the keyword finishes
703 nb_lastkey = 0
704 IF (check) THEN
705 WRITE(*, *) 'getin_readdef : Have found an emtpy line '
706 ENDIF
707 ENDIF
708 ENDDO
709
710 CLOSE(22)
711
712 IF (check) THEN
713 OPEN (22, file='run.def.test')
714 DO i=1, nb_lines
715 WRITE(22, *) targetlist(i), " : ", fichier(i)
716 ENDDO
717 CLOSE(22)
718 ENDIF
719
720 RETURN
721
722 9997 WRITE(*, *) "getin_readdef : Could not open file ", &
723 & TRIM(filelist(current))
724
725 END SUBROUTINE getin_readdef
726
727 !****************************
728
729 SUBROUTINE getin_decrypt(current, key_str, NEW_str, last_key, nb_lastkey)
730
731 ! This subroutine is going to decypher the line.
732 ! It essentialy checks how many items are included and
733 ! it they can be attached to a key.
734
735
736 ! ARGUMENTS
737
738 INTEGER :: current, nb_lastkey
739 CHARACTER(LEN=*) :: key_str, NEW_str, last_key
740
741 ! LOCAL
742
743 INTEGER :: len_str, blk, nbve, starpos
744 CHARACTER(LEN=100) :: tmp_str, new_key, mult
745 CHARACTER(LEN=3) :: cnt, chlen
746 CHARACTER(LEN=10) :: fmt
747
748 len_str = LEN_TRIM(NEW_str)
749 blk = INDEX(NEW_str(1:len_str), ' ')
750 tmp_str = NEW_str(1:len_str)
751
752 ! If the key is a new file then we take it up. Else
753 ! we save the line and go on.
754
755 IF (INDEX(key_str, 'INCLUDEDEF') > 0) THEN
756 DO WHILE (blk > 0)
757 IF (nbfiles+1 > max_files) THEN
758 WRITE(*, *) 'FATAL ERROR : Too many files to include'
759 STOP 'getin_readdef'
760 ENDIF
761
762 nbfiles = nbfiles+1
763 filelist(nbfiles) = tmp_str(1:blk)
764
765 tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
766 blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)), ' ')
767 ENDDO
768
769 IF (nbfiles+1 > max_files) THEN
770 WRITE(*, *) 'FATAL ERROR : Too many files to include'
771 STOP 'getin_readdef'
772 ENDIF
773
774 nbfiles = nbfiles+1
775 filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
776
777 last_key = 'INCLUDEDEF'
778 nb_lastkey = 1
779 ELSE
780
781 ! We are working on a new line of input
782
783 nb_lines = nb_lines+1
784 IF (nb_lines > max_lines) THEN
785 WRITE(*, *) &
786 & 'Too many line in the run.def files. You need to increase'
787 WRITE(*, *) 'the parameter max_lines in the module getincom.'
788 STOP 'getin_decrypt'
789 ENDIF
790
791 ! First we solve the issue of conpressed information. Once
792 ! this is done all line can be handled in the same way.
793
794 starpos = INDEX(NEW_str(1:len_str), '*')
795 IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
796 & .AND.(tmp_str(1:1) /= "'") ) THEN
797
798 IF (INDEX(key_str(1:len_TRIM(key_str)), '__') > 0) THEN
799 WRITE(*, *) 'ERROR : getin_decrypt'
800 WRITE(*, *) &
801 & 'We can not have a compressed field of values for in a'
802 WRITE(*, *) &
803 & 'vector notation. If a target is of the type TARGET__1'
804 WRITE(*, *) 'then only a scalar value is allowed'
805 WRITE(*, *) 'The key at fault : ', key_str(1:len_TRIM(key_str))
806 STOP 'getin_decrypt'
807 ENDIF
808
809 ! Read the multiplied
810
811 mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
812 ! Construct the new string and its parameters
813 NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
814 len_str = LEN_TRIM(NEW_str)
815 blk = INDEX(NEW_str(1:len_str), ' ')
816 IF (blk > 1) THEN
817 WRITE(*, *) &
818 & 'This is a strange behavior of getin_decrypt you could report'
819 ENDIF
820 WRITE(chlen, '(I3.3)') LEN_TRIM(mult)
821 fmt = '(I'//chlen//')'
822 READ(mult, fmt) compline(nb_lines)
823
824 ELSE
825 compline(nb_lines) = -1
826 ENDIF
827
828 ! If there is no space wthin the line then the target is a scalar
829 ! or the element of a properly written vector.
830 ! (ie of the type TARGET__1)
831
832 IF ( (blk <= 1) &
833 & .OR.(tmp_str(1:1) == '"') &
834 & .OR.(tmp_str(1:1) == "'") ) THEN
835
836 IF (nb_lastkey == 0) THEN
837 ! Save info of current keyword as a scalar
838 ! if it is not a continuation
839 targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str), 30))
840 last_key = key_str(1:MIN(len_trim(key_str), 30))
841 nb_lastkey = 1
842 ELSE
843 ! We are continuing a vector so the keyword needs
844 ! to get the underscores
845 WRITE(cnt, '(I3.3)') nb_lastkey+1
846 targetlist(nb_lines) = &
847 & key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
848 last_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
849 nb_lastkey = nb_lastkey+1
850 ENDIF
851
852 CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
853 fichier(nb_lines) = NEW_str(1:len_str)
854 fromfile(nb_lines) = current
855 ELSE
856
857 ! If there are blanks whithin the line then we are dealing
858 ! with a vector and we need to split it in many entries
859 ! with the TRAGET__1 notation.
860
861 ! Test if the targer is not already a vector target !
862
863 IF (INDEX(TRIM(key_str), '__') > 0) THEN
864 WRITE(*, *) 'ERROR : getin_decrypt'
865 WRITE(*, *) 'We have found a mixed vector notation'
866 WRITE(*, *) 'If a target is of the type TARGET__1'
867 WRITE(*, *) 'then only a scalar value is allowed'
868 WRITE(*, *) 'The key at fault : ', key_str(1:len_TRIM(key_str))
869 STOP 'getin_decrypt'
870 ENDIF
871
872 nbve = nb_lastkey
873 nbve = nbve+1
874 WRITE(cnt, '(I3.3)') nbve
875
876 DO WHILE (blk > 0)
877
878 ! Save the content of target__nbve
879
880 fichier(nb_lines) = tmp_str(1:blk)
881 new_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
882 targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key), 30))
883 CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
884 fromfile(nb_lines) = current
885
886 tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
887 blk = INDEX(TRIM(tmp_str), ' ')
888
889 nb_lines = nb_lines+1
890 IF (nb_lines > max_lines) THEN
891 WRITE(*, *) &
892 & 'Too many line in the run.def files. You need to increase'
893 WRITE(*, *) 'the parameter max_lines in the module getincom.'
894 STOP 'getin_decrypt'
895 ENDIF
896 nbve = nbve+1
897 WRITE(cnt, '(I3.3)') nbve
898
899 ENDDO
900
901 ! Save the content of the last target
902
903 fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
904 new_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
905 targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key), 30))
906 CALL gensig (targetlist(nb_lines), targetsiglist(nb_lines))
907 fromfile(nb_lines) = current
908
909 last_key = key_str(1:MIN(len_trim(key_str), 25))//'__'//cnt
910 nb_lastkey = nbve
911
912 ENDIF
913
914 ENDIF
915
916 END SUBROUTINE getin_decrypt
917
918 !****************************
919
920 SUBROUTINE getin_checkcohe ()
921
922 ! This subroutine checks for redundancies.
923
924
925 ! Arguments
926
927
928 ! LOCAL
929
930 INTEGER :: line, i, sig
931 INTEGER :: found
932 CHARACTER(LEN=30) :: str
933
934 DO line=1, nb_lines-1
935
936 CALL find_sig &
937 & (nb_lines-line, targetlist(line+1:nb_lines), targetlist(line), &
938 & targetsiglist(line+1:nb_lines), targetsiglist(line), found)
939
940 ! IF we have found it we have a problem to solve.
941
942 IF (found > 0) THEN
943 WRITE(*, *) 'COUNT : ', &
944 & COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1)
945
946 WRITE(*, *) &
947 & 'getin_checkcohe : Found a problem on key ', targetlist(line)
948 WRITE(*, *) &
949 & 'getin_checkcohe : The following values were encoutered :'
950 WRITE(*, *) &
951 & ' ', TRIM(targetlist(line)), &
952 & targetsiglist(line), ' == ', fichier(line)
953 WRITE(*, *) &
954 & ' ', TRIM(targetlist(line+found)), &
955 & targetsiglist(line+found), ' == ', fichier(line+found)
956 WRITE(*, *) &
957 & 'getin_checkcohe : We will keep only the last value'
958
959 targetsiglist(line) = 1
960 ENDIF
961 ENDDO
962
963 END SUBROUTINE getin_checkcohe
964
965 !****************************
966
967 SUBROUTINE getin_skipafew (unit, out_string, eof, nb_lastkey)
968
969
970 INTEGER :: unit, eof, nb_lastkey
971 CHARACTER(LEN=100) :: dummy
972 CHARACTER(LEN=100) :: out_string
973 CHARACTER(LEN=1) :: first
974
975 first="#"
976 eof = 0
977 out_string = " "
978
979 DO WHILE (first == "#")
980 READ (unit, '(a100)', ERR=9998, END=7778) dummy
981 dummy = TRIM(ADJUSTL(dummy))
982 first=dummy(1:1)
983 IF (first == "#") THEN
984 nb_lastkey = 0
985 ENDIF
986 ENDDO
987 out_string=dummy
988
989 RETURN
990
991 9998 WRITE(*, *) " GETIN_SKIPAFEW : Error while reading file "
992 STOP 'getin_skipafew'
993
994 7778 eof = 1
995
996 END SUBROUTINE getin_skipafew
997
998 !=== INTEGER database INTERFACE
999
1000 SUBROUTINE getdbwi &
1001 & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1002
1003 ! Write the INTEGER data into the data base
1004
1005
1006 CHARACTER(LEN=*) :: MY_TARGET
1007 INTEGER :: target_sig, status, fileorig, size_of_in
1008 INTEGER, DIMENSION(:) :: tmp_ret_val
1009
1010
1011 ! First check if we have sufficiant space for the new key
1012
1013 IF (nb_keys+1 > keymemsize) THEN
1014 CALL getin_allockeys ()
1015 ENDIF
1016
1017 ! Fill out the items of the data base
1018
1019 nb_keys = nb_keys+1
1020 keysig(nb_keys) = target_sig
1021 keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1022 keystatus(nb_keys) = status
1023 keytype(nb_keys) = 1
1024 keyfromfile(nb_keys) = fileorig
1025
1026 ! Can we compress the data base entry ?
1027
1028 IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1029 & .AND.(size_of_in > compress_lim)) THEN
1030 keymemstart(nb_keys) = intmempos+1
1031 keycompress(nb_keys) = size_of_in
1032 keymemlen(nb_keys) = 1
1033 ELSE
1034 keymemstart(nb_keys) = intmempos+1
1035 keycompress(nb_keys) = -1
1036 keymemlen(nb_keys) = size_of_in
1037 ENDIF
1038
1039 ! Before writing the actual size lets see if we have the space
1040
1041 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN
1042 CALL getin_allocmem (1, keymemlen(nb_keys))
1043 ENDIF
1044
1045 intmem(keymemstart(nb_keys): &
1046 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1047 & tmp_ret_val(1:keymemlen(nb_keys))
1048 intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1049
1050 END SUBROUTINE getdbwi
1051
1052 !****************************
1053
1054 SUBROUTINE getdbri (pos, size_of_in, MY_TARGET, tmp_ret_val)
1055
1056 ! Read the required variables in the database for INTEGERS
1057
1058
1059 INTEGER :: pos, size_of_in
1060 CHARACTER(LEN=*) :: MY_TARGET
1061 INTEGER, DIMENSION(:) :: tmp_ret_val
1062
1063 IF (keytype(pos) /= 1) THEN
1064 WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1065 STOP 'getdbri'
1066 ENDIF
1067
1068 IF (keycompress(pos) > 0) THEN
1069 IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN
1070 WRITE(*, *) &
1071 & 'FATAL ERROR : Wrong compression length for keyword ', MY_TARGET
1072 STOP 'getdbri'
1073 ELSE
1074 tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos))
1075 ENDIF
1076 ELSE
1077 IF (keymemlen(pos) /= size_of_in) THEN
1078 WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1079 STOP 'getdbri'
1080 ELSE
1081 tmp_ret_val(1:size_of_in) = &
1082 & intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1083 ENDIF
1084 ENDIF
1085
1086 END SUBROUTINE getdbri
1087
1088 !=== REAL database INTERFACE
1089
1090 SUBROUTINE getdbwr &
1091 & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1092
1093 ! Write the REAL data into the data base
1094
1095
1096 CHARACTER(LEN=*) :: MY_TARGET
1097 INTEGER :: target_sig, status, fileorig, size_of_in
1098 REAL, DIMENSION(:) :: tmp_ret_val
1099
1100
1101 ! First check if we have sufficiant space for the new key
1102
1103 IF (nb_keys+1 > keymemsize) THEN
1104 CALL getin_allockeys ()
1105 ENDIF
1106
1107 ! Fill out the items of the data base
1108
1109 nb_keys = nb_keys+1
1110 keysig(nb_keys) = target_sig
1111 keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1112 keystatus(nb_keys) = status
1113 keytype(nb_keys) = 2
1114 keyfromfile(nb_keys) = fileorig
1115
1116 ! Can we compress the data base entry ?
1117
1118 IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
1119 & .AND.(size_of_in > compress_lim)) THEN
1120 keymemstart(nb_keys) = realmempos+1
1121 keycompress(nb_keys) = size_of_in
1122 keymemlen(nb_keys) = 1
1123 ELSE
1124 keymemstart(nb_keys) = realmempos+1
1125 keycompress(nb_keys) = -1
1126 keymemlen(nb_keys) = size_of_in
1127 ENDIF
1128
1129 ! Before writing the actual size lets see if we have the space
1130
1131 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
1132 CALL getin_allocmem (2, keymemlen(nb_keys))
1133 ENDIF
1134
1135 realmem(keymemstart(nb_keys): &
1136 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1137 & tmp_ret_val(1:keymemlen(nb_keys))
1138 realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1139
1140 END SUBROUTINE getdbwr
1141
1142 !****************************
1143
1144 SUBROUTINE getdbrr (pos, size_of_in, MY_TARGET, tmp_ret_val)
1145
1146 ! Read the required variables in the database for REALS
1147
1148
1149 INTEGER :: pos, size_of_in
1150 CHARACTER(LEN=*) :: MY_TARGET
1151 REAL, DIMENSION(:) :: tmp_ret_val
1152
1153 IF (keytype(pos) /= 2) THEN
1154 WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1155 STOP 'getdbrr'
1156 ENDIF
1157
1158 IF (keycompress(pos) > 0) THEN
1159 IF ( (keycompress(pos) /= size_of_in) &
1160 & .OR.(keymemlen(pos) /= 1) ) THEN
1161 WRITE(*, *) &
1162 & 'FATAL ERROR : Wrong compression length for keyword ', MY_TARGET
1163 STOP 'getdbrr'
1164 ELSE
1165 tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos))
1166 ENDIF
1167 ELSE
1168 IF (keymemlen(pos) /= size_of_in) THEN
1169 WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1170 STOP 'getdbrr'
1171 ELSE
1172 tmp_ret_val(1:size_of_in) = &
1173 & realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1174 ENDIF
1175 ENDIF
1176
1177 END SUBROUTINE getdbrr
1178
1179 !=== LOGICAL database INTERFACE
1180
1181 SUBROUTINE getdbwl &
1182 & (MY_TARGET, target_sig, status, fileorig, size_of_in, tmp_ret_val)
1183
1184 ! Write the LOGICAL data into the data base
1185
1186
1187 CHARACTER(LEN=*) :: MY_TARGET
1188 INTEGER :: target_sig, status, fileorig, size_of_in
1189 LOGICAL, DIMENSION(:) :: tmp_ret_val
1190
1191
1192 ! First check if we have sufficiant space for the new key
1193
1194 IF (nb_keys+1 > keymemsize) THEN
1195 CALL getin_allockeys ()
1196 ENDIF
1197
1198 ! Fill out the items of the data base
1199
1200 nb_keys = nb_keys+1
1201 keysig(nb_keys) = target_sig
1202 keystr(nb_keys) = MY_TARGET(1:MIN(len_trim(MY_TARGET), 30))
1203 keystatus(nb_keys) = status
1204 keytype(nb_keys) = 4
1205 keyfromfile(nb_keys) = fileorig
1206 keymemstart(nb_keys) = logicmempos+1
1207 keymemlen(nb_keys) = size_of_in
1208
1209 ! Before writing the actual size lets see if we have the space
1210
1211 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN
1212 CALL getin_allocmem (4, keymemlen(nb_keys))
1213 ENDIF
1214
1215 logicmem(keymemstart(nb_keys): &
1216 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
1217 & tmp_ret_val(1:keymemlen(nb_keys))
1218 logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
1219
1220 END SUBROUTINE getdbwl
1221
1222 !****************************
1223
1224 SUBROUTINE getdbrl(pos, size_of_in, MY_TARGET, tmp_ret_val)
1225
1226 ! Read the required variables in the database for LOGICALS
1227
1228
1229 INTEGER :: pos, size_of_in
1230 CHARACTER(LEN=*) :: MY_TARGET
1231 LOGICAL, DIMENSION(:) :: tmp_ret_val
1232
1233 IF (keytype(pos) /= 4) THEN
1234 WRITE(*, *) 'FATAL ERROR : Wrong data type for keyword ', MY_TARGET
1235 STOP 'getdbrl'
1236 ENDIF
1237
1238 IF (keymemlen(pos) /= size_of_in) THEN
1239 WRITE(*, *) 'FATAL ERROR : Wrong array length for keyword ', MY_TARGET
1240 STOP 'getdbrl'
1241 ELSE
1242 tmp_ret_val(1:size_of_in) = &
1243 & logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
1244 ENDIF
1245
1246 END SUBROUTINE getdbrl
1247
1248 !****************************
1249
1250 SUBROUTINE getin_allockeys
1251
1252 INTEGER, ALLOCATABLE :: tmp_int(:)
1253 CHARACTER(LEN=100), ALLOCATABLE :: tmp_str(:)
1254
1255
1256
1257 !!print *, "Call sequence information: getin_allockeys"
1258 ! Either nothing exists in these arrays and it is easy to do
1259
1260 IF (keymemsize == 0) THEN
1261 ALLOCATE(keysig(memslabs))
1262 ALLOCATE(keystr(memslabs))
1263 ALLOCATE(keystatus(memslabs))
1264 ALLOCATE(keytype(memslabs))
1265 ALLOCATE(keycompress(memslabs))
1266 ALLOCATE(keyfromfile(memslabs))
1267 ALLOCATE(keymemstart(memslabs))
1268 ALLOCATE(keymemlen(memslabs))
1269 nb_keys = 0
1270 keymemsize = memslabs
1271 keycompress(:) = -1
1272 ELSE
1273 ! There is something already in the memory,
1274 ! we need to transfer and reallocate.
1275 ALLOCATE(tmp_str(keymemsize))
1276
1277 ALLOCATE(tmp_int(keymemsize))
1278 tmp_int(1:keymemsize) = keysig(1:keymemsize)
1279
1280 DEALLOCATE(keysig)
1281 ALLOCATE(keysig(keymemsize+memslabs))
1282 keysig(1:keymemsize) = tmp_int(1:keymemsize)
1283
1284 tmp_str(1:keymemsize) = keystr(1:keymemsize)
1285 DEALLOCATE(keystr)
1286 ALLOCATE(keystr(keymemsize+memslabs))
1287 keystr(1:keymemsize) = tmp_str(1:keymemsize)
1288
1289 tmp_int(1:keymemsize) = keystatus(1:keymemsize)
1290 DEALLOCATE(keystatus)
1291 ALLOCATE(keystatus(keymemsize+memslabs))
1292 keystatus(1:keymemsize) = tmp_int(1:keymemsize)
1293
1294 tmp_int(1:keymemsize) = keytype(1:keymemsize)
1295 DEALLOCATE(keytype)
1296 ALLOCATE(keytype(keymemsize+memslabs))
1297 keytype(1:keymemsize) = tmp_int(1:keymemsize)
1298
1299 tmp_int(1:keymemsize) = keycompress(1:keymemsize)
1300 DEALLOCATE(keycompress)
1301 ALLOCATE(keycompress(keymemsize+memslabs))
1302 keycompress(:) = -1
1303 keycompress(1:keymemsize) = tmp_int(1:keymemsize)
1304
1305 tmp_int(1:keymemsize) = keyfromfile(1:keymemsize)
1306 DEALLOCATE(keyfromfile)
1307 ALLOCATE(keyfromfile(keymemsize+memslabs))
1308 keyfromfile(1:keymemsize) = tmp_int(1:keymemsize)
1309
1310 tmp_int(1:keymemsize) = keymemstart(1:keymemsize)
1311 DEALLOCATE(keymemstart)
1312 ALLOCATE(keymemstart(keymemsize+memslabs))
1313 keymemstart(1:keymemsize) = tmp_int(1:keymemsize)
1314
1315 tmp_int(1:keymemsize) = keymemlen(1:keymemsize)
1316 DEALLOCATE(keymemlen)
1317 ALLOCATE(keymemlen(keymemsize+memslabs))
1318 keymemlen(1:keymemsize) = tmp_int(1:keymemsize)
1319
1320 keymemsize = keymemsize+memslabs
1321
1322 DEALLOCATE(tmp_int)
1323 DEALLOCATE(tmp_str)
1324 ENDIF
1325
1326 END SUBROUTINE getin_allockeys
1327
1328 !****************************
1329
1330 SUBROUTINE getin_allocmem (type, len_wanted)
1331
1332 ! Allocate the memory of the data base for all 4 types of memory
1333
1334 ! 1 = INTEGER
1335 ! 2 = REAL
1336 ! 3 = CHAR
1337 ! 4 = LOGICAL
1338
1339
1340 INTEGER :: type, len_wanted
1341
1342 INTEGER, ALLOCATABLE :: tmp_int(:)
1343 CHARACTER(LEN=100), ALLOCATABLE :: tmp_char(:)
1344 REAL, ALLOCATABLE :: tmp_real(:)
1345 LOGICAL, ALLOCATABLE :: tmp_logic(:)
1346 INTEGER :: ier
1347
1348 SELECT CASE (type)
1349 CASE(1)
1350 IF (intmemsize == 0) THEN
1351 ALLOCATE(intmem(memslabs), stat=ier)
1352 IF (ier /= 0) THEN
1353 WRITE(*, *) &
1354 & 'getin_allocmem : Unable to allocate db-memory intmem to ', &
1355 & memslabs
1356 STOP
1357 ENDIF
1358 intmemsize=memslabs
1359 ELSE
1360 ALLOCATE(tmp_int(intmemsize), stat=ier)
1361 IF (ier /= 0) THEN
1362 WRITE(*, *) &
1363 & 'getin_allocmem : Unable to allocate tmp_int to ', &
1364 & intmemsize
1365 STOP
1366 ENDIF
1367 tmp_int(1:intmemsize) = intmem(1:intmemsize)
1368 DEALLOCATE(intmem)
1369 ALLOCATE(intmem(intmemsize+MAX(memslabs, len_wanted)), stat=ier)
1370 IF (ier /= 0) THEN
1371 WRITE(*, *) &
1372 & 'getin_allocmem : Unable to re-allocate db-memory intmem to ', &
1373 & intmemsize+MAX(memslabs, len_wanted)
1374 STOP
1375 ENDIF
1376 intmem(1:intmemsize) = tmp_int(1:intmemsize)
1377 intmemsize = intmemsize+MAX(memslabs, len_wanted)
1378 DEALLOCATE(tmp_int)
1379 ENDIF
1380 CASE(2)
1381 IF (realmemsize == 0) THEN
1382 ALLOCATE(realmem(memslabs), stat=ier)
1383 IF (ier /= 0) THEN
1384 WRITE(*, *) &
1385 & 'getin_allocmem : Unable to allocate db-memory realmem to ', &
1386 & memslabs
1387 STOP
1388 ENDIF
1389 realmemsize = memslabs
1390 ELSE
1391 ALLOCATE(tmp_real(realmemsize), stat=ier)
1392 IF (ier /= 0) THEN
1393 WRITE(*, *) &
1394 & 'getin_allocmem : Unable to allocate tmp_real to ', &
1395 & realmemsize
1396 STOP
1397 ENDIF
1398 tmp_real(1:realmemsize) = realmem(1:realmemsize)
1399 DEALLOCATE(realmem)
1400 ALLOCATE(realmem(realmemsize+MAX(memslabs, len_wanted)), stat=ier)
1401 IF (ier /= 0) THEN
1402 WRITE(*, *) &
1403 & 'getin_allocmem : Unable to re-allocate db-memory realmem to ', &
1404 & realmemsize+MAX(memslabs, len_wanted)
1405 STOP
1406 ENDIF
1407 realmem(1:realmemsize) = tmp_real(1:realmemsize)
1408 realmemsize = realmemsize+MAX(memslabs, len_wanted)
1409 DEALLOCATE(tmp_real)
1410 ENDIF
1411 CASE(3)
1412 IF (charmemsize == 0) THEN
1413 ALLOCATE(charmem(memslabs), stat=ier)
1414 IF (ier /= 0) THEN
1415 WRITE(*, *) &
1416 & 'getin_allocmem : Unable to allocate db-memory charmem to ', &
1417 & memslabs
1418 STOP
1419 ENDIF
1420 charmemsize = memslabs
1421 ELSE
1422 ALLOCATE(tmp_char(charmemsize), stat=ier)
1423 IF (ier /= 0) THEN
1424 WRITE(*, *) &
1425 & 'getin_allocmem : Unable to allocate tmp_char to ', &
1426 & charmemsize
1427 STOP
1428 ENDIF
1429 tmp_char(1:charmemsize) = charmem(1:charmemsize)
1430 DEALLOCATE(charmem)
1431 ALLOCATE(charmem(charmemsize+MAX(memslabs, len_wanted)), stat=ier)
1432 IF (ier /= 0) THEN
1433 WRITE(*, *) &
1434 & 'getin_allocmem : Unable to re-allocate db-memory charmem to ', &
1435 & charmemsize+MAX(memslabs, len_wanted)
1436 STOP
1437 ENDIF
1438 charmem(1:charmemsize) = tmp_char(1:charmemsize)
1439 charmemsize = charmemsize+MAX(memslabs, len_wanted)
1440 DEALLOCATE(tmp_char)
1441 ENDIF
1442 CASE(4)
1443 IF (logicmemsize == 0) THEN
1444 ALLOCATE(logicmem(memslabs), stat=ier)
1445 IF (ier /= 0) THEN
1446 WRITE(*, *) &
1447 & 'getin_allocmem : Unable to allocate db-memory logicmem to ', &
1448 & memslabs
1449 STOP
1450 ENDIF
1451 logicmemsize = memslabs
1452 ELSE
1453 ALLOCATE(tmp_logic(logicmemsize), stat=ier)
1454 IF (ier /= 0) THEN
1455 WRITE(*, *) &
1456 & 'getin_allocmem : Unable to allocate tmp_logic to ', &
1457 & logicmemsize
1458 STOP
1459 ENDIF
1460 tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize)
1461 DEALLOCATE(logicmem)
1462 ALLOCATE(logicmem(logicmemsize+MAX(memslabs, len_wanted)), stat=ier)
1463 IF (ier /= 0) THEN
1464 WRITE(*, *) &
1465 & 'getin_allocmem : Unable to re-allocate db-memory logicmem to ', &
1466 & logicmemsize+MAX(memslabs, len_wanted)
1467 STOP
1468 ENDIF
1469 logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize)
1470 logicmemsize = logicmemsize+MAX(memslabs, len_wanted)
1471 DEALLOCATE(tmp_logic)
1472 ENDIF
1473 CASE DEFAULT
1474 WRITE(*, *) 'getin_allocmem : Unknown type : ', type
1475 STOP
1476 END SELECT
1477
1478 END SUBROUTINE getin_allocmem
1479
1480 END MODULE getincom2
  ViewVC Help
Powered by ViewVC 1.1.21