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

Contents of /trunk/IOIPSL/getincom.f90

Parent Directory Parent Directory | Revision Log Revision Log

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

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

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