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

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

Parent Directory Parent Directory | Revision Log Revision Log

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

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

Removed unused files.

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

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

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

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

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

Removed unused arguments of procedure "integrd".

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

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