Changeset 11 for IOIPSL/trunk/src/getincom.f90
- Timestamp:
- 03/12/07 17:01:04 (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/getincom.f90
- Property svn:keywords set to Id
r4 r11 1 !$ Header: /home/ioipsl/CVSROOT/IOIPSL/src/getincom.f90,v 2.1 2006/04/05 16:18:43 adm Exp$1 !$Id$ 2 2 !- 3 3 MODULE getincom 4 4 !--------------------------------------------------------------------- 5 USE stringop, & 6 & ONLY : findpos,nocomma,cmpblank,strlowercase,gensig,find_sig 7 !- 8 IMPLICIT NONE 9 !- 10 PRIVATE 11 PUBLIC :: getin, getin_dump 12 !- 13 INTERFACE getin 14 MODULE PROCEDURE getinrs, getinr1d, getinr2d, & 15 & getinis, getini1d, getini2d, & 16 & getincs, getinc1d, getinc2d, & 17 & getinls, getinl1d, getinl2d 18 END INTERFACE 5 USE errioipsl, ONLY : ipslerr 6 USE stringop, & 7 & ONLY : nocomma,cmpblank,strlowercase,gensig,find_sig 8 !- 9 IMPLICIT NONE 10 !- 11 PRIVATE 12 PUBLIC :: getin, getin_dump 13 !- 14 INTERFACE getin 15 MODULE PROCEDURE getinrs, getinr1d, getinr2d, & 16 & getinis, getini1d, getini2d, & 17 & getincs, getinc1d, getinc2d, & 18 & getinls, getinl1d, getinl2d 19 END INTERFACE 19 20 !- 20 21 INTEGER,PARAMETER :: max_files=100 … … 22 23 INTEGER,SAVE :: nbfiles 23 24 !- 24 INTEGER,PARAMETER :: max_lines=500 25 INTEGER,PARAMETER :: max_lines=500,l_n=30 25 26 INTEGER,SAVE :: nb_lines 26 27 CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier 27 28 INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline 28 CHARACTER(LEN=30),DIMENSION(max_lines),SAVE :: targetlist 29 CHARACTER(LEN=l_n),DIMENSION(max_lines),SAVE :: targetlist 30 !- 31 INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 32 CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' 29 33 !- 30 34 ! The data base of parameters 31 35 !- 32 36 INTEGER,PARAMETER :: memslabs=200 33 INTEGER,PARAMETER :: compress_lim =2037 INTEGER,PARAMETER :: compress_lim=20 34 38 !- 35 39 INTEGER,SAVE :: nb_keys=0 36 40 INTEGER,SAVE :: keymemsize=0 37 41 INTEGER,SAVE,ALLOCATABLE :: keysig(:) 38 CHARACTER(LEN= 30),SAVE,ALLOCATABLE :: keystr(:)42 CHARACTER(LEN=l_n),SAVE,ALLOCATABLE :: keystr(:) 39 43 !- 40 44 ! keystatus definition … … 46 50 !- 47 51 ! keytype definition 48 ! keytype = 1 : Inte rger52 ! keytype = 1 : Integer 49 53 ! keytype = 2 : Real 50 54 ! keytype = 3 : Character 51 55 ! keytype = 4 : Logical 52 56 !- 57 INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 58 !- 53 59 INTEGER,SAVE,ALLOCATABLE :: keytype(:) 54 60 !- … … 63 69 INTEGER,SAVE,ALLOCATABLE :: keymemlen(:) 64 70 !- 65 INTEGER,SAVE,ALLOCATABLE :: i ntmem(:)66 INTEGER,SAVE :: i ntmemsize=0, intmempos=067 REAL,SAVE,ALLOCATABLE :: r ealmem(:)68 INTEGER,SAVE :: r ealmemsize=0, realmempos=069 CHARACTER(LEN=100),SAVE,ALLOCATABLE :: c harmem(:)70 INTEGER,SAVE :: c harmemsize=0, charmempos=071 LOGICAL,SAVE,ALLOCATABLE :: l ogicmem(:)72 INTEGER,SAVE :: l ogicmemsize=0, logicmempos=071 INTEGER,SAVE,ALLOCATABLE :: i_mem(:) 72 INTEGER,SAVE :: i_memsize=0, i_mempos=0 73 REAL,SAVE,ALLOCATABLE :: r_mem(:) 74 INTEGER,SAVE :: r_memsize=0, r_mempos=0 75 CHARACTER(LEN=100),SAVE,ALLOCATABLE :: c_mem(:) 76 INTEGER,SAVE :: c_memsize=0, c_mempos=0 77 LOGICAL,SAVE,ALLOCATABLE :: l_mem(:) 78 INTEGER,SAVE :: l_memsize=0, l_mempos=0 73 79 !- 74 80 CONTAINS 75 81 !- 76 !=== REAL INTERFACES77 !- 78 SUBROUTINE getin rs (TARGET,ret_val)79 !--------------------------------------------------------------------- 80 !- Get a realscalar. We first check if we find it81 !- 82 !- 83 !- getinr1d and getinr2d are written on the same pattern84 !--------------------------------------------------------------------- 85 IMPLICIT NONE 86 !- 87 CHARACTER(LEN=*) :: TARGET88 REAL:: ret_val89 !- 90 REAL,DIMENSION(1) :: tmp_ret_val91 INTEGER :: target_sig, pos, status=0,fileorig82 !=== INTEGER INTERFACE 83 !- 84 SUBROUTINE getinis (target,ret_val) 85 !--------------------------------------------------------------------- 86 !- Get a interer scalar. We first check if we find it 87 !- in the database and if not we get it from the run.def 88 !- 89 !- getini1d and getini2d are written on the same pattern 90 !--------------------------------------------------------------------- 91 IMPLICIT NONE 92 !- 93 CHARACTER(LEN=*) :: target 94 INTEGER :: ret_val 95 !- 96 INTEGER,DIMENSION(1) :: tmp_ret_val 97 INTEGER :: target_sig,pos,status=0,fileorig 92 98 !--------------------------------------------------------------------- 93 99 !- 94 100 ! Compute the signature of the target 95 101 !- 96 CALL gensig ( TARGET,target_sig)102 CALL gensig (target,target_sig) 97 103 !- 98 104 ! Do we have this target in our database ? … … 104 110 IF (pos < 0) THEN 105 111 !-- Get the information out of the file 106 CALL get filr (TARGET,status,fileorig,tmp_ret_val)112 CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) 107 113 !-- Put the data into the database 108 CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val) 114 CALL get_wdb & 115 & (target,target_sig,status,fileorig,1,i_val=tmp_ret_val) 109 116 ELSE 110 117 !-- Get the value out of the database 111 CALL get dbrr (pos,1,TARGET,tmp_ret_val)118 CALL get_rdb (pos,1,target,i_val=tmp_ret_val) 112 119 ENDIF 113 120 ret_val = tmp_ret_val(1) 114 121 !--------------------- 115 END SUBROUTINE getinrs 116 !- 122 END SUBROUTINE getinis 117 123 !=== 118 !- 119 SUBROUTINE getinr1d (TARGET,ret_val) 120 !--------------------------------------------------------------------- 121 !- See getinrs for details. It is the same thing but for a vector 122 !--------------------------------------------------------------------- 123 IMPLICIT NONE 124 !- 125 CHARACTER(LEN=*) :: TARGET 126 REAL,DIMENSION(:) :: ret_val 127 !- 128 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 124 SUBROUTINE getini1d (target,ret_val) 125 !--------------------------------------------------------------------- 126 !- See getinis for details. It is the same thing but for a vector 127 !--------------------------------------------------------------------- 128 IMPLICIT NONE 129 !- 130 CHARACTER(LEN=*) :: target 131 INTEGER,DIMENSION(:) :: ret_val 132 !- 133 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 129 134 INTEGER,SAVE :: tmp_ret_size = 0 130 INTEGER :: target_sig, pos, size_of_in, status=0,fileorig135 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 131 136 !--------------------------------------------------------------------- 132 137 !- 133 138 ! Compute the signature of the target 134 139 !- 135 CALL gensig ( TARGET,target_sig)140 CALL gensig (target,target_sig) 136 141 !- 137 142 ! Do we have this target in our database ? … … 150 155 !- 151 156 IF (pos < 0) THEN 152 !-- Ge the information out of the file153 CALL get filr (TARGET,status,fileorig,tmp_ret_val)157 !-- Get the information out of the file 158 CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) 154 159 !-- Put the data into the database 155 CALL get dbwr&156 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)160 CALL get_wdb & 161 & (target,target_sig,status,fileorig,size_of_in,i_val=tmp_ret_val) 157 162 ELSE 158 163 !-- Get the value out of the database 159 CALL get dbrr (pos,size_of_in,TARGET,tmp_ret_val)164 CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) 160 165 ENDIF 161 166 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) 162 167 !---------------------- 163 END SUBROUTINE getinr1d 164 !- 168 END SUBROUTINE getini1d 165 169 !=== 166 !- 167 SUBROUTINE getinr2d (TARGET,ret_val) 168 !--------------------------------------------------------------------- 169 !- See getinrs for details. It is the same thing but for a matrix 170 !--------------------------------------------------------------------- 171 IMPLICIT NONE 172 !- 173 CHARACTER(LEN=*) :: TARGET 174 REAL,DIMENSION(:,:) :: ret_val 175 !- 176 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 170 SUBROUTINE getini2d (target,ret_val) 171 !--------------------------------------------------------------------- 172 !- See getinis for details. It is the same thing but for a matrix 173 !--------------------------------------------------------------------- 174 IMPLICIT NONE 175 !- 176 CHARACTER(LEN=*) :: target 177 INTEGER,DIMENSION(:,:) :: ret_val 178 !- 179 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 177 180 INTEGER,SAVE :: tmp_ret_size = 0 178 181 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig 179 INTEGER :: jl, jj,ji182 INTEGER :: jl,jj,ji 180 183 !--------------------------------------------------------------------- 181 184 !- 182 185 ! Compute the signature of the target 183 186 !- 184 CALL gensig ( TARGET,target_sig)187 CALL gensig (target,target_sig) 185 188 !- 186 189 ! Do we have this target in our database ? … … 208 211 !- 209 212 IF (pos < 0) THEN 210 !-- Ge the information out of the file211 CALL get filr (TARGET,status,fileorig,tmp_ret_val)213 !-- Get the information out of the file 214 CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) 212 215 !-- Put the data into the database 213 CALL get dbwr&214 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)216 CALL get_wdb & 217 & (target,target_sig,status,fileorig,size_of_in,i_val=tmp_ret_val) 215 218 ELSE 216 219 !-- Get the value out of the database 217 CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val) 220 CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) 221 ENDIF 222 !- 223 jl=0 224 DO jj=1,size_2 225 DO ji=1,size_1 226 jl=jl+1 227 ret_val(ji,jj) = tmp_ret_val(jl) 228 ENDDO 229 ENDDO 230 !---------------------- 231 END SUBROUTINE getini2d 232 !- 233 !=== REAL INTERFACE 234 !- 235 SUBROUTINE getinrs (target,ret_val) 236 !--------------------------------------------------------------------- 237 !- Get a real scalar. We first check if we find it 238 !- in the database and if not we get it from the run.def 239 !- 240 !- getinr1d and getinr2d are written on the same pattern 241 !--------------------------------------------------------------------- 242 IMPLICIT NONE 243 !- 244 CHARACTER(LEN=*) :: target 245 REAL :: ret_val 246 !- 247 REAL,DIMENSION(1) :: tmp_ret_val 248 INTEGER :: target_sig,pos,status=0,fileorig 249 !--------------------------------------------------------------------- 250 !- 251 ! Compute the signature of the target 252 !- 253 CALL gensig (target,target_sig) 254 !- 255 ! Do we have this target in our database ? 256 !- 257 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 258 !- 259 tmp_ret_val(1) = ret_val 260 !- 261 IF (pos < 0) THEN 262 !-- Get the information out of the file 263 CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) 264 !-- Put the data into the database 265 CALL get_wdb & 266 & (target,target_sig,status,fileorig,1,r_val=tmp_ret_val) 267 ELSE 268 !-- Get the value out of the database 269 CALL get_rdb (pos,1,target,r_val=tmp_ret_val) 270 ENDIF 271 ret_val = tmp_ret_val(1) 272 !--------------------- 273 END SUBROUTINE getinrs 274 !=== 275 SUBROUTINE getinr1d (target,ret_val) 276 !--------------------------------------------------------------------- 277 !- See getinrs for details. It is the same thing but for a vector 278 !--------------------------------------------------------------------- 279 IMPLICIT NONE 280 !- 281 CHARACTER(LEN=*) :: target 282 REAL,DIMENSION(:) :: ret_val 283 !- 284 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 285 INTEGER,SAVE :: tmp_ret_size = 0 286 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 287 !--------------------------------------------------------------------- 288 !- 289 ! Compute the signature of the target 290 !- 291 CALL gensig (target,target_sig) 292 !- 293 ! Do we have this target in our database ? 294 !- 295 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 296 !- 297 size_of_in = SIZE(ret_val) 298 IF (.NOT.ALLOCATED(tmp_ret_val)) THEN 299 ALLOCATE (tmp_ret_val(size_of_in)) 300 ELSE IF (size_of_in > tmp_ret_size) THEN 301 DEALLOCATE (tmp_ret_val) 302 ALLOCATE (tmp_ret_val(size_of_in)) 303 tmp_ret_size = size_of_in 304 ENDIF 305 tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) 306 !- 307 IF (pos < 0) THEN 308 !-- Get the information out of the file 309 CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) 310 !-- Put the data into the database 311 CALL get_wdb & 312 & (target,target_sig,status,fileorig,size_of_in,r_val=tmp_ret_val) 313 ELSE 314 !-- Get the value out of the database 315 CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) 316 ENDIF 317 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) 318 !---------------------- 319 END SUBROUTINE getinr1d 320 !=== 321 SUBROUTINE getinr2d (target,ret_val) 322 !--------------------------------------------------------------------- 323 !- See getinrs for details. It is the same thing but for a matrix 324 !--------------------------------------------------------------------- 325 IMPLICIT NONE 326 !- 327 CHARACTER(LEN=*) :: target 328 REAL,DIMENSION(:,:) :: ret_val 329 !- 330 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 331 INTEGER,SAVE :: tmp_ret_size = 0 332 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig 333 INTEGER :: jl,jj,ji 334 !--------------------------------------------------------------------- 335 !- 336 ! Compute the signature of the target 337 !- 338 CALL gensig (target,target_sig) 339 !- 340 ! Do we have this target in our database ? 341 !- 342 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 343 !- 344 size_of_in = SIZE(ret_val) 345 size_1 = SIZE(ret_val,1) 346 size_2 = SIZE(ret_val,2) 347 IF (.NOT.ALLOCATED(tmp_ret_val)) THEN 348 ALLOCATE (tmp_ret_val(size_of_in)) 349 ELSE IF (size_of_in > tmp_ret_size) THEN 350 DEALLOCATE (tmp_ret_val) 351 ALLOCATE (tmp_ret_val(size_of_in)) 352 tmp_ret_size = size_of_in 353 ENDIF 354 !- 355 jl=0 356 DO jj=1,size_2 357 DO ji=1,size_1 358 jl=jl+1 359 tmp_ret_val(jl) = ret_val(ji,jj) 360 ENDDO 361 ENDDO 362 !- 363 IF (pos < 0) THEN 364 !-- Get the information out of the file 365 CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) 366 !-- Put the data into the database 367 CALL get_wdb & 368 & (target,target_sig,status,fileorig,size_of_in,r_val=tmp_ret_val) 369 ELSE 370 !-- Get the value out of the database 371 CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) 218 372 ENDIF 219 373 !- … … 228 382 END SUBROUTINE getinr2d 229 383 !- 230 !=== 231 !- 232 SUBROUTINE getfilr (TARGET,status,fileorig,ret_val) 233 !--------------------------------------------------------------------- 234 !- Subroutine that will extract from the file the values 235 !- attributed to the keyword target 236 !- 237 !- REALS 238 !- ----- 239 !- 240 !- target : in : CHARACTER(LEN=*) target for which we will 241 !- look in the file 242 !- status : out : INTEGER tells us from where we obtained the data 243 !- fileorig : out : The index of the file from which the key comes 244 !- ret_val : out : REAL(nb_to_ret) values read 245 !--------------------------------------------------------------------- 246 IMPLICIT NONE 247 !- 248 CHARACTER(LEN=*) :: TARGET 249 INTEGER :: status, fileorig 250 REAL,DIMENSION(:) :: ret_val 251 !- 252 INTEGER :: nb_to_ret 253 INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt 254 CHARACTER(LEN=3) :: cnt, tl, dl 255 CHARACTER(LEN=10) :: fmt 256 CHARACTER(LEN=30) :: full_target 257 CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp 258 INTEGER :: full_target_sig 259 REAL :: compvalue 260 !- 261 INTEGER,SAVE :: max_len = 0 262 LOGICAL,SAVE,ALLOCATABLE :: found(:) 263 LOGICAL,SAVE :: def_beha 264 LOGICAL :: compressed = .FALSE. 265 !--------------------------------------------------------------------- 266 nb_to_ret = SIZE(ret_val) 267 CALL getin_read 268 !- 269 ! Get the variables and memory we need 270 !- 271 IF (max_len == 0) THEN 272 ALLOCATE(found(nb_to_ret)) 273 max_len = nb_to_ret 274 ENDIF 275 IF (max_len < nb_to_ret) THEN 276 DEALLOCATE(found) 277 ALLOCATE(found(nb_to_ret)) 278 max_len = nb_to_ret 279 ENDIF 280 found(:) = .FALSE. 281 !- 282 ! See what we find in the files read 283 !- 284 DO it=1,nb_to_ret 285 !--- 286 !- 287 !-- First try the target as it is 288 !--- 289 full_target = TARGET(1:len_TRIM(target)) 290 CALL gensig (full_target,full_target_sig) 291 CALL find_sig (nb_lines,targetlist,full_target, & 292 & targetsiglist,full_target_sig,pos) 293 !--- 294 !-- Another try 295 !--- 296 IF (pos < 0) THEN 297 WRITE(cnt,'(I3.3)') it 298 full_target = TARGET(1:len_TRIM(target))//'__'//cnt 299 CALL gensig (full_target,full_target_sig) 300 CALL find_sig (nb_lines,targetlist,full_target, & 301 & targetsiglist,full_target_sig,pos) 302 ENDIF 303 !--- 304 !-- A priori we dont know from which file the target could come. 305 !-- Thus by default we attribute it to the first file : 306 !--- 307 fileorig = 1 308 !-- 309 IF (pos > 0) THEN 310 !---- 311 found(it) = .TRUE. 312 fileorig = fromfile(pos) 313 !----- 314 !---- DECODE 315 !----- 316 str_READ = TRIM(ADJUSTL(fichier(pos))) 317 str_READ_lower = str_READ 318 CALL strlowercase (str_READ_lower) 319 !---- 320 IF ( ( (INDEX(str_READ_lower,'def') == 1) & 321 & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & 322 & .OR.( (INDEX(str_READ_lower,'default') == 1) & 323 & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN 324 def_beha = .TRUE. 325 ELSE 326 def_beha = .FALSE. 327 len_str = LEN_TRIM(str_READ) 328 epos = INDEX(str_READ,'e') 329 ppos = INDEX(str_READ,'.') 330 !------ 331 IF (epos > 0) THEN 332 WRITE(tl,'(I3.3)') len_str 333 WRITE(dl,'(I3.3)') epos-ppos-1 334 fmt='(e'//tl//'.'//dl//')' 335 READ(str_READ,fmt) ret_val(it) 336 ELSE IF (ppos > 0) THEN 337 WRITE(tl,'(I3.3)') len_str 338 WRITE(dl,'(I3.3)') len_str-ppos 339 fmt='(f'//tl//'.'//dl//')' 340 READ(str_READ,fmt) ret_val(it) 341 ELSE 342 WRITE(tl,'(I3.3)') len_str 343 fmt = '(I'//tl//')' 344 READ(str_READ,fmt) int_tmp 345 ret_val(it) = REAL(int_tmp) 346 ENDIF 347 ENDIF 348 !---- 349 targetsiglist(pos) = -1 350 !----- 351 !---- Is this the value of a compressed field ? 352 !----- 353 IF (compline(pos) > 0) THEN 354 IF (compline(pos) == nb_to_ret) THEN 355 compressed = .TRUE. 356 compvalue = ret_val(it) 357 ELSE 358 WRITE(*,*) 'WARNING from getfilr' 359 WRITE(*,*) 'For key ',TRIM(TARGET), & 360 & ' we have a compressed field but which does not have the right size.' 361 WRITE(*,*) 'We will try to fix that ' 362 compressed = .TRUE. 363 compvalue = ret_val(it) 364 ENDIF 365 ENDIF 366 ELSE 367 found(it) = .FALSE. 368 ENDIF 369 ENDDO 370 !-- 371 ! If this is a compressed field then we will uncompress it 372 !-- 373 IF (compressed) THEN 374 DO it=1,nb_to_ret 375 IF (.NOT. found(it)) THEN 376 ret_val(it) = compvalue 377 found(it) = .TRUE. 378 ENDIF 379 ENDDO 380 ENDIF 381 !- 382 ! Now we get the status for what we found 383 !- 384 IF (def_beha) THEN 385 status = 2 386 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) 384 !=== CHARACTER INTERFACE 385 !- 386 SUBROUTINE getincs (target,ret_val) 387 !--------------------------------------------------------------------- 388 !- Get a CHARACTER scalar. We first check if we find it 389 !- in the database and if not we get it from the run.def 390 !- 391 !- getinc1d and getinc2d are written on the same pattern 392 !--------------------------------------------------------------------- 393 IMPLICIT NONE 394 !- 395 CHARACTER(LEN=*) :: target 396 CHARACTER(LEN=*) :: ret_val 397 !- 398 CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val 399 INTEGER :: target_sig,pos,status=0,fileorig 400 !--------------------------------------------------------------------- 401 !- 402 ! Compute the signature of the target 403 !- 404 CALL gensig (target,target_sig) 405 !- 406 ! Do we have this target in our database ? 407 !- 408 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 409 !- 410 tmp_ret_val(1) = ret_val 411 !- 412 IF (pos < 0) THEN 413 !-- Get the information out of the file 414 CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) 415 !-- Put the data into the database 416 CALL get_wdb & 417 & (target,target_sig,status,fileorig,1,c_val=tmp_ret_val) 387 418 ELSE 388 status_cnt = 0389 DO it=1,nb_to_ret390 IF (.NOT. found(it)) THEN391 status_cnt = status_cnt+1392 IF (nb_to_ret > 1) THEN393 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it394 ELSE395 str_tmp = TRIM(TARGET)396 ENDIF397 WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)398 ENDIF399 ENDDO400 !---401 IF (status_cnt == 0) THEN402 status = 1403 ELSE IF (status_cnt == nb_to_ret) THEN404 status = 2405 ELSE406 status = 3407 ENDIF408 ENDIF409 !---------------------410 END SUBROUTINE getfilr411 !-412 !=== INTEGER INTERFACES413 !-414 SUBROUTINE getinis (TARGET,ret_val)415 !---------------------------------------------------------------------416 !- Get a interer scalar. We first check if we find it417 !- in the database and if not we get it from the run.def418 !-419 !- getini1d and getini2d are written on the same pattern420 !---------------------------------------------------------------------421 IMPLICIT NONE422 !-423 CHARACTER(LEN=*) :: TARGET424 INTEGER :: ret_val425 !-426 INTEGER,DIMENSION(1) :: tmp_ret_val427 INTEGER :: target_sig, pos, status=0, fileorig428 !---------------------------------------------------------------------429 !-430 ! Compute the signature of the target431 !-432 CALL gensig (TARGET,target_sig)433 !-434 ! Do we have this target in our database ?435 !-436 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)437 !-438 tmp_ret_val(1) = ret_val439 !-440 IF (pos < 0) THEN441 !-- Ge the information out of the file442 CALL getfili (TARGET,status,fileorig,tmp_ret_val)443 !-- Put the data into the database444 CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val)445 ELSE446 419 !-- Get the value out of the database 447 CALL get dbri (pos,1,TARGET,tmp_ret_val)420 CALL get_rdb (pos,1,target,c_val=tmp_ret_val) 448 421 ENDIF 449 422 ret_val = tmp_ret_val(1) 450 423 !--------------------- 451 END SUBROUTINE getinis 452 !- 424 END SUBROUTINE getincs 453 425 !=== 454 !- 455 SUBROUTINE getini1d (TARGET,ret_val) 456 !--------------------------------------------------------------------- 457 !- See getinis for details. It is the same thing but for a vector 458 !--------------------------------------------------------------------- 459 IMPLICIT NONE 460 !- 461 CHARACTER(LEN=*) :: TARGET 462 INTEGER,DIMENSION(:) :: ret_val 463 !- 464 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 426 SUBROUTINE getinc1d (target,ret_val) 427 !--------------------------------------------------------------------- 428 !- See getincs for details. It is the same thing but for a vector 429 !--------------------------------------------------------------------- 430 IMPLICIT NONE 431 !- 432 CHARACTER(LEN=*) :: target 433 CHARACTER(LEN=*),DIMENSION(:) :: ret_val 434 !- 435 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 465 436 INTEGER,SAVE :: tmp_ret_size = 0 466 INTEGER :: target_sig, pos, size_of_in, status=0,fileorig437 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 467 438 !--------------------------------------------------------------------- 468 439 !- 469 440 ! Compute the signature of the target 470 441 !- 471 CALL gensig ( TARGET,target_sig)442 CALL gensig (target,target_sig) 472 443 !- 473 444 ! Do we have this target in our database ? … … 486 457 !- 487 458 IF (pos < 0) THEN 488 !-- Ge the information out of the file489 CALL get fili (TARGET,status,fileorig,tmp_ret_val)459 !-- Get the information out of the file 460 CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) 490 461 !-- Put the data into the database 491 CALL get dbwi&492 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)462 CALL get_wdb & 463 & (target,target_sig,status,fileorig,size_of_in,c_val=tmp_ret_val) 493 464 ELSE 494 465 !-- Get the value out of the database 495 CALL get dbri (pos,size_of_in,TARGET,tmp_ret_val)466 CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) 496 467 ENDIF 497 468 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) 498 469 !---------------------- 499 END SUBROUTINE getini1d 500 !- 470 END SUBROUTINE getinc1d 501 471 !=== 502 !- 503 SUBROUTINE getini2d (TARGET,ret_val) 504 !--------------------------------------------------------------------- 505 !- See getinis for details. It is the same thing but for a matrix 506 !--------------------------------------------------------------------- 507 IMPLICIT NONE 508 !- 509 CHARACTER(LEN=*) :: TARGET 510 INTEGER,DIMENSION(:,:) :: ret_val 511 !- 512 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 472 SUBROUTINE getinc2d (target,ret_val) 473 !--------------------------------------------------------------------- 474 !- See getincs for details. It is the same thing but for a matrix 475 !--------------------------------------------------------------------- 476 IMPLICIT NONE 477 !- 478 CHARACTER(LEN=*) :: target 479 CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val 480 !- 481 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 513 482 INTEGER,SAVE :: tmp_ret_size = 0 514 483 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig 515 INTEGER :: jl, jj,ji484 INTEGER :: jl,jj,ji 516 485 !--------------------------------------------------------------------- 517 486 !- 518 487 ! Compute the signature of the target 519 488 !- 520 CALL gensig ( TARGET,target_sig)489 CALL gensig (target,target_sig) 521 490 !- 522 491 ! Do we have this target in our database ? … … 544 513 !- 545 514 IF (pos < 0) THEN 546 !-- Ge the information out of the file547 CALL get fili (TARGET,status,fileorig,tmp_ret_val)515 !-- Get the information out of the file 516 CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) 548 517 !-- Put the data into the database 549 CALL get dbwi&550 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)518 CALL get_wdb & 519 & (target,target_sig,status,fileorig,size_of_in,c_val=tmp_ret_val) 551 520 ELSE 552 521 !-- Get the value out of the database 553 CALL get dbri (pos,size_of_in,TARGET,tmp_ret_val)522 CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) 554 523 ENDIF 555 524 !- … … 562 531 ENDDO 563 532 !---------------------- 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 IMPLICIT NONE 583 !- 584 CHARACTER(LEN=*) :: TARGET 585 INTEGER :: status, fileorig 586 INTEGER :: ret_val(:) 587 !- 588 INTEGER :: nb_to_ret 589 INTEGER :: it, pos, len_str, status_cnt 590 CHARACTER(LEN=3) :: cnt, chlen 591 CHARACTER(LEN=10) :: fmt 592 CHARACTER(LEN=30) :: full_target 593 CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp 594 INTEGER :: full_target_sig 595 INTEGER :: compvalue 596 !- 597 INTEGER,SAVE :: max_len = 0 598 LOGICAL,SAVE,ALLOCATABLE :: found(:) 599 LOGICAL,SAVE :: def_beha 600 LOGICAL :: compressed = .FALSE. 601 !--------------------------------------------------------------------- 602 nb_to_ret = SIZE(ret_val) 603 CALL getin_read 604 !- 605 ! Get the variables and memory we need 606 !- 607 IF (max_len == 0) THEN 608 ALLOCATE(found(nb_to_ret)) 609 max_len = nb_to_ret 610 ENDIF 611 IF (max_len < nb_to_ret) THEN 612 DEALLOCATE(found) 613 ALLOCATE(found(nb_to_ret)) 614 max_len = nb_to_ret 615 ENDIF 616 found(:) = .FALSE. 617 !- 618 ! See what we find in the files read 619 !- 620 DO it=1,nb_to_ret 621 !--- 622 !-- First try the target as it is 623 !--- 624 full_target = TARGET(1:len_TRIM(target)) 625 CALL gensig (full_target,full_target_sig) 626 CALL find_sig (nb_lines,targetlist,full_target, & 627 & targetsiglist,full_target_sig,pos) 628 !--- 629 !-- Another try 630 !--- 631 IF (pos < 0) THEN 632 WRITE(cnt,'(I3.3)') it 633 full_target = TARGET(1:len_TRIM(target))//'__'//cnt 634 CALL gensig (full_target,full_target_sig) 635 CALL find_sig (nb_lines,targetlist,full_target, & 636 & targetsiglist,full_target_sig,pos) 637 ENDIF 638 !--- 639 !-- A priori we dont know from which file the target could come. 640 !-- Thus by default we attribute it to the first file : 641 !--- 642 fileorig = 1 643 !- 644 IF (pos > 0) THEN 645 !----- 646 found(it) = .TRUE. 647 fileorig = fromfile(pos) 648 !----- 649 !---- DECODE 650 !---- 651 str_READ = TRIM(ADJUSTL(fichier(pos))) 652 str_READ_lower = str_READ 653 CALL strlowercase (str_READ_lower) 654 !----- 655 IF ( ( (INDEX(str_READ_lower,'def') == 1) & 656 & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & 657 & .OR.( (INDEX(str_READ_lower,'default') == 1) & 658 & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN 659 def_beha = .TRUE. 660 ELSE 661 def_beha = .FALSE. 662 len_str = LEN_TRIM(str_READ) 663 WRITE(chlen,'(I3.3)') len_str 664 fmt = '(I'//chlen//')' 665 READ(str_READ,fmt) ret_val(it) 666 ENDIF 667 !----- 668 targetsiglist(pos) = -1 669 !----- 670 !---- Is this the value of a compressed field ? 671 !----- 672 IF (compline(pos) > 0) THEN 673 IF (compline(pos) == nb_to_ret) THEN 674 compressed = .TRUE. 675 compvalue = ret_val(it) 676 ELSE 677 WRITE(*,*) 'WARNING from getfilr' 678 WRITE(*,*) 'For key ',TRIM(TARGET), & 679 & ' we have a compressed field but which does not have the right size.' 680 WRITE(*,*) 'We will try to fix that ' 681 compressed = .TRUE. 682 compvalue = ret_val(it) 683 ENDIF 684 ENDIF 685 ELSE 686 found(it) = .FALSE. 687 ENDIF 688 ENDDO 689 !- 690 ! If this is a compressed field then we will uncompress it 691 !- 692 IF (compressed) THEN 693 DO it=1,nb_to_ret 694 IF (.NOT. found(it)) THEN 695 ret_val(it) = compvalue 696 found(it) = .TRUE. 697 ENDIF 698 ENDDO 699 ENDIF 700 !- 701 ! Now we get the status for what we found 702 !- 703 IF (def_beha) THEN 704 status = 2 705 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) 706 ELSE 707 status_cnt = 0 708 DO it=1,nb_to_ret 709 IF (.NOT. found(it)) THEN 710 status_cnt = status_cnt+1 711 IF (nb_to_ret > 1) THEN 712 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it 713 ELSE 714 str_tmp = TRIM(TARGET) 715 ENDIF 716 WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) 717 ENDIF 718 ENDDO 719 !--- 720 IF (status_cnt == 0) THEN 721 status = 1 722 ELSE IF (status_cnt == nb_to_ret) THEN 723 status = 2 724 ELSE 725 status = 3 726 ENDIF 727 ENDIF 728 !--------------------- 729 END SUBROUTINE getfili 730 !- 731 !=== CHARACTER INTERFACES 732 !- 733 SUBROUTINE getincs (TARGET,ret_val) 734 !--------------------------------------------------------------------- 735 !- Get a CHARACTER scalar. We first check if we find it 533 END SUBROUTINE getinc2d 534 !- 535 !=== LOGICAL INTERFACE 536 !- 537 SUBROUTINE getinls (target,ret_val) 538 !--------------------------------------------------------------------- 539 !- Get a logical scalar. We first check if we find it 736 540 !- in the database and if not we get it from the run.def 737 541 !- 738 !- getin c1d and getinc2d are written on the same pattern739 !--------------------------------------------------------------------- 740 IMPLICIT NONE 741 !- 742 CHARACTER(LEN=*) :: TARGET743 CHARACTER(LEN=*):: ret_val744 !- 745 CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val746 INTEGER :: target_sig, pos, status=0,fileorig542 !- getinl1d and getinl2d are written on the same pattern 543 !--------------------------------------------------------------------- 544 IMPLICIT NONE 545 !- 546 CHARACTER(LEN=*) :: target 547 LOGICAL :: ret_val 548 !- 549 LOGICAL,DIMENSION(1) :: tmp_ret_val 550 INTEGER :: target_sig,pos,status=0,fileorig 747 551 !--------------------------------------------------------------------- 748 552 !- 749 553 ! Compute the signature of the target 750 554 !- 751 CALL gensig ( TARGET,target_sig)555 CALL gensig (target,target_sig) 752 556 !- 753 557 ! Do we have this target in our database ? … … 758 562 !- 759 563 IF (pos < 0) THEN 760 !-- Ge the information out of the file761 CALL get filc (TARGET,status,fileorig,tmp_ret_val)564 !-- Get the information out of the file 565 CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) 762 566 !-- Put the data into the database 763 CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val) 567 CALL get_wdb & 568 & (target,target_sig,status,fileorig,1,l_val=tmp_ret_val) 764 569 ELSE 765 570 !-- Get the value out of the database 766 CALL get dbrc (pos,1,TARGET,tmp_ret_val)571 CALL get_rdb (pos,1,target,l_val=tmp_ret_val) 767 572 ENDIF 768 573 ret_val = tmp_ret_val(1) 769 574 !--------------------- 770 END SUBROUTINE getincs 771 !- 575 END SUBROUTINE getinls 772 576 !=== 773 !- 774 SUBROUTINE getinc1d (TARGET,ret_val) 775 !--------------------------------------------------------------------- 776 !- See getincs for details. It is the same thing but for a vector 777 !--------------------------------------------------------------------- 778 IMPLICIT NONE 779 !- 780 CHARACTER(LEN=*) :: TARGET 781 CHARACTER(LEN=*),DIMENSION(:) :: ret_val 782 !- 783 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 577 SUBROUTINE getinl1d (target,ret_val) 578 !--------------------------------------------------------------------- 579 !- See getinls for details. It is the same thing but for a vector 580 !--------------------------------------------------------------------- 581 IMPLICIT NONE 582 !- 583 CHARACTER(LEN=*) :: target 584 LOGICAL,DIMENSION(:) :: ret_val 585 !- 586 LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 784 587 INTEGER,SAVE :: tmp_ret_size = 0 785 INTEGER :: target_sig, pos, size_of_in, status=0,fileorig588 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 786 589 !--------------------------------------------------------------------- 787 590 !- 788 591 ! Compute the signature of the target 789 592 !- 790 CALL gensig ( TARGET,target_sig)593 CALL gensig (target,target_sig) 791 594 !- 792 595 ! Do we have this target in our database ? … … 805 608 !- 806 609 IF (pos < 0) THEN 807 !-- Ge the information out of the file808 CALL get filc (TARGET,status,fileorig,tmp_ret_val)610 !-- Get the information out of the file 611 CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) 809 612 !-- Put the data into the database 810 CALL get dbwc&811 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)613 CALL get_wdb & 614 & (target,target_sig,status,fileorig,size_of_in,l_val=tmp_ret_val) 812 615 ELSE 813 616 !-- Get the value out of the database 814 CALL get dbrc (pos,size_of_in,TARGET,tmp_ret_val)617 CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) 815 618 ENDIF 816 619 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) 817 620 !---------------------- 818 END SUBROUTINE getinc1d 819 !- 621 END SUBROUTINE getinl1d 820 622 !=== 821 !- 822 SUBROUTINE getinc2d (TARGET,ret_val) 823 !--------------------------------------------------------------------- 824 !- See getincs for details. It is the same thing but for a matrix 825 !--------------------------------------------------------------------- 826 IMPLICIT NONE 827 !- 828 CHARACTER(LEN=*) :: TARGET 829 CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val 830 !- 831 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 623 SUBROUTINE getinl2d (target,ret_val) 624 !--------------------------------------------------------------------- 625 !- See getinls for details. It is the same thing but for a matrix 626 !--------------------------------------------------------------------- 627 IMPLICIT NONE 628 !- 629 CHARACTER(LEN=*) :: target 630 LOGICAL,DIMENSION(:,:) :: ret_val 631 !- 632 LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 832 633 INTEGER,SAVE :: tmp_ret_size = 0 833 634 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig … … 837 638 ! Compute the signature of the target 838 639 !- 839 CALL gensig ( TARGET,target_sig)640 CALL gensig (target,target_sig) 840 641 !- 841 642 ! Do we have this target in our database ? … … 863 664 !- 864 665 IF (pos < 0) THEN 865 !-- Ge the information out of the file866 CALL get filc (TARGET,status,fileorig,tmp_ret_val)666 !-- Get the information out of the file 667 CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) 867 668 !-- Put the data into the database 868 CALL get dbwc&869 & ( TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)669 CALL get_wdb & 670 & (target,target_sig,status,fileorig,size_of_in,l_val=tmp_ret_val) 870 671 ELSE 871 672 !-- 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 IMPLICIT NONE 902 !- 903 !- 904 CHARACTER(LEN=*) :: TARGET 905 INTEGER :: status, fileorig 906 CHARACTER(LEN=*),DIMENSION(:) :: ret_val 907 !- 908 INTEGER :: nb_to_ret 909 INTEGER :: it, pos, len_str, status_cnt 910 CHARACTER(LEN=3) :: cnt 911 CHARACTER(LEN=30) :: full_target 912 CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp 913 INTEGER :: full_target_sig 914 !- 915 INTEGER,SAVE :: max_len = 0 916 LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found 917 LOGICAL,SAVE :: def_beha 918 !--------------------------------------------------------------------- 919 nb_to_ret = SIZE(ret_val) 920 CALL getin_read 921 !- 922 ! Get the variables and memory we need 923 !- 924 IF (max_len == 0) THEN 925 ALLOCATE(found(nb_to_ret)) 926 max_len = nb_to_ret 927 ENDIF 928 IF (max_len < nb_to_ret) THEN 929 DEALLOCATE(found) 930 ALLOCATE(found(nb_to_ret)) 931 max_len = nb_to_ret 932 ENDIF 933 found(:) = .FALSE. 934 !- 935 ! See what we find in the files read 936 !- 937 DO it=1,nb_to_ret 938 !--- 939 !-- First try the target as it is 940 full_target = TARGET(1:len_TRIM(target)) 941 CALL gensig (full_target,full_target_sig) 942 CALL find_sig (nb_lines,targetlist,full_target, & 943 & targetsiglist,full_target_sig,pos) 944 !--- 945 !-- Another try 946 !--- 947 IF (pos < 0) THEN 948 WRITE(cnt,'(I3.3)') it 949 full_target = TARGET(1:len_TRIM(target))//'__'//cnt 950 CALL gensig (full_target,full_target_sig) 951 CALL find_sig (nb_lines,targetlist,full_target, & 952 & targetsiglist,full_target_sig,pos) 953 ENDIF 954 !--- 955 !-- A priori we dont know from which file the target could come. 956 !-- Thus by default we attribute it to the first file : 957 !--- 958 fileorig = 1 959 !--- 960 IF (pos > 0) THEN 961 !----- 962 found(it) = .TRUE. 963 fileorig = fromfile(pos) 964 !----- 965 !---- DECODE 966 !----- 967 str_READ = TRIM(ADJUSTL(fichier(pos))) 968 str_READ_lower = str_READ 969 CALL strlowercase (str_READ_lower) 970 !----- 971 IF ( ( (INDEX(str_READ_lower,'def') == 1) & 972 & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & 973 & .OR.( (INDEX(str_READ_lower,'default') == 1) & 974 & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN 975 def_beha = .TRUE. 976 ELSE 977 def_beha = .FALSE. 978 len_str = LEN_TRIM(str_READ) 979 ret_val(it) = str_READ(1:len_str) 980 ENDIF 981 !----- 982 targetsiglist(pos) = -1 983 !----- 984 ELSE 985 found(it) = .FALSE. 986 ENDIF 987 ENDDO 988 !- 989 ! Now we get the status for what we found 990 !- 991 IF (def_beha) THEN 992 status = 2 993 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET) 994 ELSE 995 status_cnt = 0 996 DO it=1,nb_to_ret 997 IF (.NOT. found(it)) THEN 998 status_cnt = status_cnt+1 999 IF (nb_to_ret > 1) THEN 1000 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it 1001 ELSE 1002 str_tmp = TARGET(1:len_TRIM(target)) 1003 ENDIF 1004 WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it) 1005 ENDIF 1006 ENDDO 1007 !- 1008 IF (status_cnt == 0) THEN 1009 status = 1 1010 ELSE IF (status_cnt == nb_to_ret) THEN 1011 status = 2 1012 ELSE 1013 status = 3 1014 ENDIF 1015 ENDIF 1016 !--------------------- 1017 END SUBROUTINE getfilc 1018 !- 1019 !=== LOGICAL INTERFACES 1020 !- 1021 SUBROUTINE getinls (TARGET,ret_val) 1022 !--------------------------------------------------------------------- 1023 !- Get a logical scalar. We first check if we find it 1024 !- in the database and if not we get it from the run.def 1025 !- 1026 !- getinl1d and getinl2d are written on the same pattern 1027 !--------------------------------------------------------------------- 1028 IMPLICIT NONE 1029 !- 1030 CHARACTER(LEN=*) :: TARGET 1031 LOGICAL :: ret_val 1032 !- 1033 LOGICAL,DIMENSION(1) :: tmp_ret_val 1034 INTEGER :: target_sig, pos, status=0, fileorig 1035 !--------------------------------------------------------------------- 1036 !- 1037 ! Compute the signature of the target 1038 !- 1039 CALL gensig (TARGET,target_sig) 1040 !- 1041 ! Do we have this target in our database ? 1042 !- 1043 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 1044 !- 1045 tmp_ret_val(1) = ret_val 1046 !- 1047 IF (pos < 0) THEN 1048 !-- Ge the information out of the file 1049 CALL getfill (TARGET,status,fileorig,tmp_ret_val) 1050 !-- Put the data into the database 1051 CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val) 1052 ELSE 1053 !-- Get the value out of the database 1054 CALL getdbrl (pos,1,TARGET,tmp_ret_val) 1055 ENDIF 1056 ret_val = tmp_ret_val(1) 1057 !--------------------- 1058 END SUBROUTINE getinls 1059 !- 1060 !=== 1061 !- 1062 SUBROUTINE getinl1d (TARGET,ret_val) 1063 !--------------------------------------------------------------------- 1064 !- See getinls for details. It is the same thing but for a vector 1065 !--------------------------------------------------------------------- 1066 IMPLICIT NONE 1067 !- 1068 CHARACTER(LEN=*) :: TARGET 1069 LOGICAL,DIMENSION(:) :: ret_val 1070 !- 1071 LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 1072 INTEGER,SAVE :: tmp_ret_size = 0 1073 INTEGER :: target_sig, pos, size_of_in, status=0, fileorig 1074 !--------------------------------------------------------------------- 1075 !- 1076 ! Compute the signature of the target 1077 !- 1078 CALL gensig (TARGET,target_sig) 1079 !- 1080 ! Do we have this target in our database ? 1081 !- 1082 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos) 1083 !- 1084 size_of_in = SIZE(ret_val) 1085 IF (.NOT.ALLOCATED(tmp_ret_val)) THEN 1086 ALLOCATE (tmp_ret_val(size_of_in)) 1087 ELSE IF (size_of_in > tmp_ret_size) THEN 1088 DEALLOCATE (tmp_ret_val) 1089 ALLOCATE (tmp_ret_val(size_of_in)) 1090 tmp_ret_size = size_of_in 1091 ENDIF 1092 tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) 1093 !- 1094 IF (pos < 0) THEN 1095 !-- Ge the information out of the file 1096 CALL getfill (TARGET,status,fileorig,tmp_ret_val) 1097 !-- Put the data into the database 1098 CALL getdbwl & 1099 & (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val) 1100 ELSE 1101 !-- Get the value out of the database 1102 CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val) 1103 ENDIF 1104 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) 1105 !---------------------- 1106 END SUBROUTINE getinl1d 1107 !- 1108 !=== 1109 !- 1110 SUBROUTINE getinl2d (TARGET,ret_val) 1111 !--------------------------------------------------------------------- 1112 !- See getinls for details. It is the same thing but for a matrix 1113 !--------------------------------------------------------------------- 1114 IMPLICIT NONE 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) 673 CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) 1161 674 ENDIF 1162 675 !- … … 1171 684 END SUBROUTINE getinl2d 1172 685 !- 1173 !=== 1174 !- 1175 SUBROUTINE get fill (TARGET,status,fileorig,ret_val)686 !=== Generic file/database INTERFACE 687 !- 688 SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) 1176 689 !--------------------------------------------------------------------- 1177 690 !- Subroutine that will extract from the file the values 1178 691 !- attributed to the keyword target 1179 692 !- 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 IMPLICIT NONE 1190 !- 1191 CHARACTER(LEN=*) :: TARGET 1192 INTEGER :: status, fileorig 1193 LOGICAL,DIMENSION(:) :: ret_val 1194 !- 1195 INTEGER :: nb_to_ret 1196 INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt 1197 CHARACTER(LEN=3) :: cnt 1198 CHARACTER(LEN=30) :: full_target 1199 CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp 693 !- (C) target : target for which we will look in the file 694 !- (I) status : tells us from where we obtained the data 695 !- (I) fileorig : index of the file from which the key comes 696 !- (I) i_val(:) : INTEGER(nb_to_ret) values 697 !- (R) r_val(:) : REAL(nb_to_ret) values 698 !- (L) l_val(:) : LOGICAL(nb_to_ret) values 699 !- (C) c_val(:) : CHARACTER(nb_to_ret) values 700 !--------------------------------------------------------------------- 701 IMPLICIT NONE 702 !- 703 CHARACTER(LEN=*) :: target 704 INTEGER,INTENT(OUT) :: status,fileorig 705 INTEGER,DIMENSION(:),OPTIONAL :: i_val 706 REAL,DIMENSION(:),OPTIONAL :: r_val 707 LOGICAL,DIMENSION(:),OPTIONAL :: l_val 708 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val 709 !- 710 INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err 711 CHARACTER(LEN=n_d_fmt) :: cnt 712 CHARACTER(LEN=37) :: full_target 713 CHARACTER(LEN=80) :: str_READ,str_READ_lower 714 CHARACTER(LEN=9) :: c_vtyp 1200 715 INTEGER :: full_target_sig 1201 !- 1202 INTEGER,SAVE :: max_len = 0 1203 LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found 1204 LOGICAL,SAVE :: def_beha 1205 !--------------------------------------------------------------------- 1206 nb_to_ret = SIZE(ret_val) 716 LOGICAL,DIMENSION(:),ALLOCATABLE :: found 717 LOGICAL :: def_beha,compressed 718 CHARACTER(LEN=10) :: c_fmt 719 INTEGER :: i_cmpval 720 REAL :: r_cmpval 721 INTEGER :: ipos_tr,ipos_fl 722 !--------------------------------------------------------------------- 723 !- 724 ! Get the type of the argument 725 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 726 SELECT CASE (k_typ) 727 CASE(k_i) 728 nb_to_ret = SIZE(i_val) 729 CASE(k_r) 730 nb_to_ret = SIZE(r_val) 731 CASE(k_c) 732 nb_to_ret = SIZE(c_val) 733 CASE(k_l) 734 nb_to_ret = SIZE(l_val) 735 CASE DEFAULT 736 CALL ipslerr (3,'get_fil', & 737 & 'Internal error','Unknown type of data',' ') 738 END SELECT 739 !- 740 ! Read the file(s) 1207 741 CALL getin_read 1208 742 !- 1209 ! Get the variables and memory we need 1210 !- 1211 IF (max_len == 0) THEN 1212 ALLOCATE(found(nb_to_ret)) 1213 max_len = nb_to_ret 1214 ENDIF 1215 IF (max_len < nb_to_ret) THEN 1216 DEALLOCATE(found) 1217 ALLOCATE(found(nb_to_ret)) 1218 max_len = nb_to_ret 1219 ENDIF 743 ! Allocate and initialize the memory we need 744 ALLOCATE(found(nb_to_ret)) 1220 745 found(:) = .FALSE. 1221 746 !- 1222 747 ! See what we find in the files read 1223 !-1224 748 DO it=1,nb_to_ret 1225 749 !--- 1226 750 !-- First try the target as it is 1227 !--- 1228 full_target = TARGET(1:len_TRIM(target)) 751 full_target = target 1229 752 CALL gensig (full_target,full_target_sig) 1230 753 CALL find_sig (nb_lines,targetlist,full_target, & … … 1234 757 !--- 1235 758 IF (pos < 0) THEN 1236 WRITE( cnt,'(I3.3)') it1237 full_target = T ARGET(1:len_TRIM(target))//'__'//cnt759 WRITE(UNIT=cnt,FMT=c_i_fmt) it 760 full_target = TRIM(target)//'__'//cnt 1238 761 CALL gensig (full_target,full_target_sig) 1239 762 CALL find_sig (nb_lines,targetlist,full_target, & … … 1241 764 ENDIF 1242 765 !--- 1243 !-- A priori we dont know from which file the target could come.766 !-- We dont know from which file the target could come. 1244 767 !-- Thus by default we attribute it to the first file : 1245 !---1246 768 fileorig = 1 1247 769 !--- … … 1253 775 !---- DECODE 1254 776 !----- 1255 str_READ = TRIM(ADJUSTL(fichier(pos)))777 str_READ = ADJUSTL(fichier(pos)) 1256 778 str_READ_lower = str_READ 1257 779 CALL strlowercase (str_READ_lower) 1258 780 !----- 1259 IF ( ( (INDEX(str_READ_lower,'def') == 1) & 1260 & .AND.(LEN_TRIM(str_READ_lower) == 3) ) & 1261 & .OR.( (INDEX(str_READ_lower,'default') == 1) & 1262 & .AND.(LEN_TRIM(str_READ_lower) == 7) ) ) THEN 781 IF ( (TRIM(str_READ_lower) == 'def') & 782 & .OR.(TRIM(str_READ_lower) == 'default') ) THEN 1263 783 def_beha = .TRUE. 1264 784 ELSE 1265 785 def_beha = .FALSE. 1266 786 len_str = LEN_TRIM(str_READ) 1267 ipos_tr = -1 1268 ipos_fl = -1 1269 !------- 1270 ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), & 1271 & INDEX(str_READ,'y'),INDEX(str_READ,'Y')) 1272 ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), & 1273 & INDEX(str_READ,'n'),INDEX(str_READ,'N')) 1274 !------- 1275 IF (ipos_tr > 0) THEN 1276 ret_val(it) = .TRUE. 1277 ELSE IF (ipos_fl > 0) THEN 1278 ret_val(it) = .FALSE. 1279 ELSE 1280 WRITE(*,*) "ERROR : getfill : TARGET ", & 1281 & TRIM(TARGET)," is not of logical value" 1282 STOP 'getinl' 787 io_err = 0 788 SELECT CASE (k_typ) 789 CASE(k_i) 790 WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str 791 READ (UNIT=str_READ(1:len_str), & 792 & FMT=c_fmt,IOSTAT=io_err) i_val(it) 793 CASE(k_r) 794 READ (UNIT=str_READ(1:len_str), & 795 & FMT=*,IOSTAT=io_err) r_val(it) 796 CASE(k_c) 797 c_val(it) = str_READ(1:len_str) 798 CASE(k_l) 799 ipos_tr = -1 800 ipos_fl = -1 801 ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & 802 & INDEX(str_READ_lower,'y')) 803 ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & 804 & INDEX(str_READ_lower,'n')) 805 IF (ipos_tr > 0) THEN 806 l_val(it) = .TRUE. 807 ELSE IF (ipos_fl > 0) THEN 808 l_val(it) = .FALSE. 809 ELSE 810 io_err = 100 811 ENDIF 812 END SELECT 813 IF (io_err /= 0) THEN 814 CALL ipslerr (3,'get_fil', & 815 & 'Target '//TRIM(target), & 816 & 'is not of '//TRIM(c_vtyp)//' type',' ') 1283 817 ENDIF 1284 818 ENDIF … … 1286 820 targetsiglist(pos) = -1 1287 821 !----- 822 IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN 823 !------- 824 !------ Is this the value of a compressed field ? 825 compressed = (compline(pos) > 0) 826 IF (compressed) THEN 827 IF (compline(pos) /= nb_to_ret) THEN 828 CALL ipslerr (2,'get_fil', & 829 & 'For key '//TRIM(target)//' we have a compressed field', & 830 & 'which does not have the right size.', & 831 & 'We will try to fix that.') 832 ENDIF 833 IF (k_typ == k_i) THEN 834 i_cmpval = i_val(it) 835 ELSE IF (k_typ == k_r) THEN 836 r_cmpval = r_val(it) 837 ENDIF 838 ENDIF 839 ENDIF 1288 840 ELSE 1289 !-1290 841 found(it) = .FALSE. 1291 !- 1292 ENDIF1293 !- 842 def_beha = .FALSE. 843 compressed = .FALSE. 844 ENDIF 1294 845 ENDDO 1295 846 !- 1296 ! Now we get the status for what we found 1297 !- 847 IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN 848 !--- 849 !-- If this is a compressed field then we will uncompress it 850 IF (compressed) THEN 851 DO it=1,nb_to_ret 852 IF (.NOT.found(it)) THEN 853 IF (k_typ == k_i) THEN 854 i_val(it) = i_cmpval 855 ELSE IF (k_typ == k_r) THEN 856 ENDIF 857 found(it) = .TRUE. 858 ENDIF 859 ENDDO 860 ENDIF 861 ENDIF 862 !- 863 ! Now we set the status for what we found 1298 864 IF (def_beha) THEN 1299 865 status = 2 1300 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM( TARGET)866 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) 1301 867 ELSE 1302 868 status_cnt = 0 1303 869 DO it=1,nb_to_ret 1304 IF (.NOT. 870 IF (.NOT.found(it)) THEN 1305 871 status_cnt = status_cnt+1 1306 IF (nb_to_ret > 1) THEN 1307 WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it 1308 ELSE 1309 str_tmp = TRIM(TARGET) 872 IF (status_cnt <= max_msgs) THEN 873 WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & 874 & ADVANCE='NO') TRIM(target) 875 IF (nb_to_ret > 1) THEN 876 WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') 877 WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it 878 ENDIF 879 SELECT CASE (k_typ) 880 CASE(k_i) 881 WRITE (UNIT=*,FMT=*) "=",i_val(it) 882 CASE(k_r) 883 WRITE (UNIT=*,FMT=*) "=",r_val(it) 884 CASE(k_c) 885 WRITE (UNIT=*,FMT=*) "=",c_val(it) 886 CASE(k_l) 887 WRITE (UNIT=*,FMT=*) "=",l_val(it) 888 END SELECT 889 ELSE IF (status_cnt == max_msgs+1) THEN 890 WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') 1310 891 ENDIF 1311 WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)1312 892 ENDIF 1313 893 ENDDO … … 1321 901 ENDIF 1322 902 ENDIF 903 ! Deallocate the memory 904 DEALLOCATE(found) 1323 905 !--------------------- 1324 END SUBROUTINE getfill 1325 !- 906 END SUBROUTINE get_fil 1326 907 !=== 908 SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) 909 !--------------------------------------------------------------------- 910 !- Read the required variable in the database 911 !--------------------------------------------------------------------- 912 IMPLICIT NONE 913 !- 914 INTEGER :: pos,size_of_in 915 CHARACTER(LEN=*) :: target 916 INTEGER,DIMENSION(:),OPTIONAL :: i_val 917 REAL,DIMENSION(:),OPTIONAL :: r_val 918 LOGICAL,DIMENSION(:),OPTIONAL :: l_val 919 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val 920 !- 921 INTEGER :: k_typ 922 CHARACTER(LEN=9) :: c_vtyp 923 !--------------------------------------------------------------------- 924 !- 925 ! Get the type of the argument 926 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 927 IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & 928 & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN 929 CALL ipslerr (3,'get_rdb', & 930 & 'Internal error','Unknown type of data',' ') 931 ENDIF 932 !- 933 IF (keytype(pos) /= k_typ) THEN 934 CALL ipslerr (3,'get_rdb', & 935 & 'Wrong data type for keyword '//TRIM(target), & 936 & '(NOT '//TRIM(c_vtyp)//')',' ') 937 ENDIF 938 !- 939 IF (keycompress(pos) > 0) THEN 940 IF ( (keycompress(pos) /= size_of_in) & 941 & .OR.(keymemlen(pos) /= 1) ) THEN 942 CALL ipslerr (3,'get_rdb', & 943 & 'Wrong compression length','for keyword '//TRIM(target),' ') 944 ELSE 945 SELECT CASE (k_typ) 946 CASE(k_i) 947 i_val(1:size_of_in) = i_mem(keymemstart(pos)) 948 CASE(k_r) 949 r_val(1:size_of_in) = r_mem(keymemstart(pos)) 950 END SELECT 951 ENDIF 952 ELSE 953 IF (keymemlen(pos) /= size_of_in) THEN 954 CALL ipslerr (3,'get_rdb', & 955 & 'Wrong array length','for keyword '//TRIM(target),' ') 956 ELSE 957 SELECT CASE (k_typ) 958 CASE(k_i) 959 i_val(1:size_of_in) = & 960 & i_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 961 CASE(k_r) 962 r_val(1:size_of_in) = & 963 & r_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 964 CASE(k_c) 965 c_val(1:size_of_in) = & 966 & c_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 967 CASE(k_l) 968 l_val(1:size_of_in) = & 969 & l_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 970 END SELECT 971 ENDIF 972 ENDIF 973 !--------------------- 974 END SUBROUTINE get_rdb 975 !=== 976 SUBROUTINE get_wdb & 977 & (target,target_sig,status,fileorig,size_of_in, & 978 & i_val,r_val,c_val,l_val) 979 !--------------------------------------------------------------------- 980 !- Write data into the data base 981 !--------------------------------------------------------------------- 982 IMPLICIT NONE 983 !- 984 CHARACTER(LEN=*) :: target 985 INTEGER :: target_sig,status,fileorig,size_of_in 986 INTEGER,DIMENSION(:),OPTIONAL :: i_val 987 REAL,DIMENSION(:),OPTIONAL :: r_val 988 LOGICAL,DIMENSION(:),OPTIONAL :: l_val 989 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val 990 !- 991 INTEGER :: k_typ 992 CHARACTER(LEN=9) :: c_vtyp 993 INTEGER :: k_mempos,k_memsize,k_len 994 LOGICAL :: l_cmp 995 !--------------------------------------------------------------------- 996 !- 997 ! Get the type of the argument 998 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 999 IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & 1000 & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN 1001 CALL ipslerr (3,'get_wdb', & 1002 & 'Internal error','Unknown type of data',' ') 1003 ENDIF 1004 !- 1005 ! First check if we have sufficiant space for the new key 1006 IF (nb_keys+1 > keymemsize) THEN 1007 CALL getin_allockeys () 1008 ENDIF 1009 !- 1010 SELECT CASE (k_typ) 1011 CASE(k_i) 1012 k_mempos = i_mempos; k_memsize = i_memsize; 1013 l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & 1014 & .AND.(size_of_in > compress_lim) 1015 CASE(k_r) 1016 k_mempos = r_mempos; k_memsize = r_memsize; 1017 l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & 1018 & .AND.(size_of_in > compress_lim) 1019 CASE(k_c) 1020 k_mempos = c_mempos; k_memsize = c_memsize; 1021 l_cmp = .FALSE. 1022 CASE(k_l) 1023 k_mempos = l_mempos; k_memsize = l_memsize; 1024 l_cmp = .FALSE. 1025 END SELECT 1026 !- 1027 ! Fill out the items of the data base 1028 nb_keys = nb_keys+1 1029 keysig(nb_keys) = target_sig 1030 keystr(nb_keys) = target(1:MIN(LEN_TRIM(target),l_n)) 1031 keystatus(nb_keys) = status 1032 keytype(nb_keys) = k_typ 1033 keyfromfile(nb_keys) = fileorig 1034 keymemstart(nb_keys) = k_mempos+1 1035 IF (l_cmp) THEN 1036 keycompress(nb_keys) = size_of_in 1037 keymemlen(nb_keys) = 1 1038 ELSE 1039 keycompress(nb_keys) = -1 1040 keymemlen(nb_keys) = size_of_in 1041 ENDIF 1042 !- 1043 ! Before writing the actual size lets see if we have the space 1044 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > k_memsize) THEN 1045 CALL getin_allocmem (k_typ,keymemlen(nb_keys)) 1046 ENDIF 1047 !- 1048 k_len = keymemstart(nb_keys)+keymemlen(nb_keys)-1 1049 SELECT CASE (k_typ) 1050 CASE(k_i) 1051 i_mem(keymemstart(nb_keys):k_len) = i_val(1:keymemlen(nb_keys)) 1052 i_mempos = k_len 1053 CASE(k_r) 1054 r_mem(keymemstart(nb_keys):k_len) = r_val(1:keymemlen(nb_keys)) 1055 r_mempos = k_len 1056 CASE(k_c) 1057 c_mem(keymemstart(nb_keys):k_len) = c_val(1:keymemlen(nb_keys)) 1058 c_mempos = k_len 1059 CASE(k_l) 1060 l_mem(keymemstart(nb_keys):k_len) = l_val(1:keymemlen(nb_keys)) 1061 l_mempos = k_len 1062 END SELECT 1063 !--------------------- 1064 END SUBROUTINE get_wdb 1065 !- 1066 !=== 1327 1067 !- 1328 1068 SUBROUTINE getin_read … … 1331 1071 !- 1332 1072 INTEGER,SAVE :: allread=0 1333 INTEGER,SAVE :: current ,i1073 INTEGER,SAVE :: current 1334 1074 !--------------------------------------------------------------------- 1335 1075 IF (allread == 0) THEN 1336 1076 !-- Allocate a first set of memory. 1337 1077 CALL getin_allockeys 1338 CALL getin_allocmem ( 1,0)1339 CALL getin_allocmem ( 2,0)1340 CALL getin_allocmem ( 3,0)1341 CALL getin_allocmem ( 4,0)1078 CALL getin_allocmem (k_i,0) 1079 CALL getin_allocmem (k_r,0) 1080 CALL getin_allocmem (k_c,0) 1081 CALL getin_allocmem (k_l,0) 1342 1082 !-- Start with reading the files 1343 1083 nbfiles = 1 … … 1368 1108 INTEGER :: current 1369 1109 !- 1370 CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str 1371 CHARACTER(LEN=3) :: cnt 1110 CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str 1111 CHARACTER(LEN=n_d_fmt) :: cnt 1112 CHARACTER(LEN=10) :: c_fmt 1372 1113 INTEGER :: nb_lastkey 1373 1114 !- 1374 INTEGER :: eof, ptn, len_str, i, it, iund1115 INTEGER :: eof,ptn,len_str,i,it,iund,io_err 1375 1116 LOGICAL :: check = .FALSE. 1376 1117 !--------------------------------------------------------------------- … … 1383 1124 ENDIF 1384 1125 !- 1385 OPEN (22,file=filelist(current),ERR=9997,STATUS="OLD") 1126 OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) 1127 IF (io_err /= 0) THEN 1128 CALL ipslerr (2,'getin_readdef', & 1129 & 'Could not open file '//TRIM(filelist(current)),' ',' ') 1130 RETURN 1131 ENDIF 1386 1132 !- 1387 1133 DO WHILE (eof /= 1) … … 1394 1140 !---- Get the target 1395 1141 key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) 1396 !---- Make sure that ifa vector keyword has the right length1397 iund = 1142 !---- Make sure that a vector keyword has the right length 1143 iund = INDEX(key_str,'__') 1398 1144 IF (iund > 0) THEN 1399 SELECTCASE( len_trim(key_str)-iund ) 1400 CASE(2) 1401 READ(key_str(iund+2:len_trim(key_str)),'(I1)') it 1402 CASE(3) 1403 READ(key_str(iund+2:len_trim(key_str)),'(I2)') it 1404 CASE(4) 1405 READ(key_str(iund+2:len_trim(key_str)),'(I3)') it 1406 CASE DEFAULT 1407 it = -1 1408 END SELECT 1409 IF (it > 0) THEN 1410 WRITE(cnt,'(I3.3)') it 1145 WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & 1146 & LEN_TRIM(key_str)-iund-1 1147 READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & 1148 & FMT=c_fmt,IOSTAT=io_err) it 1149 IF ( (io_err == 0).AND.(it > 0) ) THEN 1150 WRITE(UNIT=cnt,FMT=c_i_fmt) it 1411 1151 key_str = key_str(1:iund+1)//cnt 1412 1152 ELSE 1413 WRITE(*,*) & 1414 & 'getin_readdef : A very strange key has just been found' 1415 WRITE(*,*) 'getin_readdef : ',key_str(1:len_TRIM(key_str)) 1416 STOP 'getin_readdef' 1153 CALL ipslerr (3,'getin_readdef', & 1154 & 'A very strange key has just been found :', & 1155 & TRIM(key_str),' ') 1417 1156 ENDIF 1418 1157 ENDIF … … 1443 1182 ELSE 1444 1183 IF (nb_lastkey /= 1) THEN 1445 WRITE(*,*) & 1446 & 'getin_readdef : An error has occured. We can not have a scalar' 1447 WRITE(*,*) 'getin_readdef : keywod and a vector content' 1448 STOP 'getin_readdef' 1184 CALL ipslerr (3,'getin_readdef', & 1185 & 'We can not have a scalar keyword', & 1186 & 'and a vector content',' ') 1449 1187 ENDIF 1450 1188 !-------- The last keyword needs to be transformed into a vector. 1189 WRITE(UNIT=cnt,FMT=c_i_fmt) 1 1451 1190 targetlist(nb_lines) = & 1452 & last_key(1:MIN(len_trim(last_key),30))//'__001'1191 & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt 1453 1192 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) 1454 key_str = last_key(1: len_TRIM(last_key))1193 key_str = last_key(1:LEN_TRIM(last_key)) 1455 1194 ENDIF 1456 1195 ENDIF … … 1459 1198 CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) 1460 1199 ELSE 1461 !---- If we have an empty line the the keyword finishes1200 !---- If we have an empty line then the keyword finishes 1462 1201 nb_lastkey = 0 1463 1202 IF (check) THEN … … 1467 1206 ENDDO 1468 1207 !- 1469 CLOSE( 22)1208 CLOSE(UNIT=22) 1470 1209 !- 1471 1210 IF (check) THEN 1472 OPEN ( 22,file='run.def.test')1211 OPEN (UNIT=22,file='run.def.test') 1473 1212 DO i=1,nb_lines 1474 WRITE( 22,*) targetlist(i)," : ",fichier(i)1213 WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) 1475 1214 ENDDO 1476 CLOSE(22) 1477 ENDIF 1478 !- 1479 RETURN 1480 !- 1481 9997 WRITE(*,*) "getin_readdef : Could not open file ", & 1482 & TRIM(filelist(current)) 1215 CLOSE(UNIT=22) 1216 ENDIF 1483 1217 !--------------------------- 1484 1218 END SUBROUTINE getin_readdef … … 1496 1230 ! ARGUMENTS 1497 1231 !- 1498 INTEGER :: current, 1499 CHARACTER(LEN=*) :: key_str, NEW_str,last_key1232 INTEGER :: current,nb_lastkey 1233 CHARACTER(LEN=*) :: key_str,NEW_str,last_key 1500 1234 !- 1501 1235 ! LOCAL 1502 1236 !- 1503 INTEGER :: len_str, blk, nbve,starpos1504 CHARACTER(LEN=100) :: tmp_str, new_key,mult1505 CHARACTER(LEN= 3) :: cnt, chlen1506 CHARACTER(LEN=10) ::fmt1237 INTEGER :: len_str,blk,nbve,starpos 1238 CHARACTER(LEN=100) :: tmp_str,new_key,mult 1239 CHARACTER(LEN=n_d_fmt) :: cnt 1240 CHARACTER(LEN=10) :: c_fmt 1507 1241 !--------------------------------------------------------------------- 1508 1242 len_str = LEN_TRIM(NEW_str) … … 1516 1250 DO WHILE (blk > 0) 1517 1251 IF (nbfiles+1 > max_files) THEN 1518 WRITE(*,*) 'FATAL ERROR : Too many files to include'1519 STOP 'getin_readdef'1252 CALL ipslerr (3,'getin_decrypt', & 1253 & 'Too many files to include',' ',' ') 1520 1254 ENDIF 1521 1255 !----- … … 1528 1262 !--- 1529 1263 IF (nbfiles+1 > max_files) THEN 1530 WRITE(*,*) 'FATAL ERROR : Too many files to include'1531 STOP 'getin_readdef'1264 CALL ipslerr (3,'getin_decrypt', & 1265 & 'Too many files to include',' ',' ') 1532 1266 ENDIF 1533 1267 !--- … … 1543 1277 nb_lines = nb_lines+1 1544 1278 IF (nb_lines > max_lines) THEN 1545 WRITE(*,*)&1546 & 'Too many line in the run.def files. You need to increase'1547 WRITE(*,*) 'the parameter max_lines in the module getincom.'1548 STOP 'getin_decrypt'1279 CALL ipslerr (3,'getin_decrypt', & 1280 & 'Too many lines in the run.def files.', & 1281 & 'You need to increase', & 1282 & 'the parameter max_lines in the module getincom.') 1549 1283 ENDIF 1550 1284 !- … … 1556 1290 & .AND.(tmp_str(1:1) /= "'") ) THEN 1557 1291 !----- 1558 IF (INDEX(key_str(1:len_TRIM(key_str)),'__') > 0) THEN 1559 WRITE(*,*) 'ERROR : getin_decrypt' 1560 WRITE(*,*) & 1561 & 'We can not have a compressed field of values for in a' 1562 WRITE(*,*) & 1563 & 'vector notation. If a target is of the type TARGET__1' 1564 WRITE(*,*) 'then only a scalar value is allowed' 1565 WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) 1566 STOP 'getin_decrypt' 1292 IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN 1293 CALL ipslerr (3,'getin_decrypt', & 1294 & 'We can not have a compressed field of values', & 1295 & 'in a vector notation (TARGET__n).', & 1296 & 'The key at fault : '//TRIM(key_str)) 1567 1297 ENDIF 1568 1298 !- … … 1575 1305 blk = INDEX(NEW_str(1:len_str),' ') 1576 1306 IF (blk > 1) THEN 1577 WRITE(*,*) & 1578 & 'This is a strange behavior of getin_decrypt you could report' 1579 ENDIF 1580 WRITE(chlen,'(I3.3)') LEN_TRIM(mult) 1581 fmt = '(I'//chlen//')' 1582 READ(mult,fmt) compline(nb_lines) 1307 CALL ipslerr (2,'getin_decrypt', & 1308 & 'This is a strange behavior','you could report',' ') 1309 ENDIF 1310 WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) 1311 READ(UNIT=mult,FMT=c_fmt) compline(nb_lines) 1583 1312 !--- 1584 1313 ELSE … … 1588 1317 !-- If there is no space wthin the line then the target is a scalar 1589 1318 !-- or the element of a properly written vector. 1590 !-- (ie of the type TARGET__ 1)1319 !-- (ie of the type TARGET__00001) 1591 1320 !- 1592 1321 IF ( (blk <= 1) & … … 1597 1326 !------ Save info of current keyword as a scalar 1598 1327 !------ if it is not a continuation 1599 targetlist(nb_lines) = key_str(1:MIN( len_trim(key_str),30))1600 last_key = key_str(1:MIN( len_trim(key_str),30))1328 targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n)) 1329 last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) 1601 1330 nb_lastkey = 1 1602 1331 ELSE 1603 1332 !------ We are continuing a vector so the keyword needs 1604 1333 !------ to get the underscores 1605 WRITE( cnt,'(I3.3)') nb_lastkey+11334 WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 1606 1335 targetlist(nb_lines) = & 1607 & key_str(1:MIN(len_trim(key_str),25))//'__'//cnt 1608 last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt 1336 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1337 last_key = & 1338 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1609 1339 nb_lastkey = nb_lastkey+1 1610 1340 ENDIF … … 1617 1347 !---- If there are blanks whithin the line then we are dealing 1618 1348 !---- with a vector and we need to split it in many entries 1619 !---- with the T RAGET__1notation.1349 !---- with the TARGET__n notation. 1620 1350 !---- 1621 1351 !---- Test if the targer is not already a vector target ! 1622 1352 !- 1623 1353 IF (INDEX(TRIM(key_str),'__') > 0) THEN 1624 WRITE(*,*) 'ERROR : getin_decrypt' 1625 WRITE(*,*) 'We have found a mixed vector notation' 1626 WRITE(*,*) 'If a target is of the type TARGET__1' 1627 WRITE(*,*) 'then only a scalar value is allowed' 1628 WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str)) 1629 STOP 'getin_decrypt' 1354 CALL ipslerr (3,'getin_decrypt', & 1355 & 'We have found a mixed vector notation (TARGET__n).', & 1356 & 'The key at fault : '//TRIM(key_str),' ') 1630 1357 ENDIF 1631 1358 !- 1632 1359 nbve = nb_lastkey 1633 1360 nbve = nbve+1 1634 WRITE( cnt,'(I3.3)') nbve1361 WRITE(UNIT=cnt,FMT=c_i_fmt) nbve 1635 1362 !- 1636 1363 DO WHILE (blk > 0) … … 1639 1366 !- 1640 1367 fichier(nb_lines) = tmp_str(1:blk) 1641 new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt 1642 targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) 1368 new_key = & 1369 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1370 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1643 1371 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) 1644 1372 fromfile(nb_lines) = current … … 1649 1377 nb_lines = nb_lines+1 1650 1378 IF (nb_lines > max_lines) THEN 1651 WRITE(*,*)&1652 & 'Too many line in the run.def files. You need to increase'1653 WRITE(*,*) 'the parameter max_lines in the module getincom.'1654 STOP 'getin_decrypt'1379 CALL ipslerr (3,'getin_decrypt', & 1380 & 'Too many lines in the run.def files.', & 1381 & 'You need to increase', & 1382 & 'the parameter max_lines in the module getincom.') 1655 1383 ENDIF 1656 1384 nbve = nbve+1 1657 WRITE( cnt,'(I3.3)') nbve1385 WRITE(UNIT=cnt,FMT=c_i_fmt) nbve 1658 1386 !- 1659 1387 ENDDO … … 1662 1390 !- 1663 1391 fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) 1664 new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt 1665 targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30)) 1392 new_key = & 1393 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1394 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1666 1395 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines)) 1667 1396 fromfile(nb_lines) = current 1668 1397 !- 1669 last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt 1398 last_key = & 1399 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1670 1400 nb_lastkey = nbve 1671 1401 !- … … 1684 1414 IMPLICIT NONE 1685 1415 !- 1686 ! Arguments 1687 !- 1688 !- 1689 ! LOCAL 1690 !- 1691 INTEGER :: line,i,sig 1692 INTEGER :: found 1693 CHARACTER(LEN=30) :: str 1416 INTEGER :: line,found 1694 1417 !--------------------------------------------------------------------- 1695 1418 DO line=1,nb_lines-1 … … 1706 1429 !----- 1707 1430 WRITE(*,*) & 1708 & 'getin_checkcohe : Found a problem on key ', targetlist(line)1431 & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) 1709 1432 WRITE(*,*) & 1710 1433 & 'getin_checkcohe : The following values were encoutered :' … … 1721 1444 ENDIF 1722 1445 ENDDO 1723 !- 1446 !----------------------------- 1724 1447 END SUBROUTINE getin_checkcohe 1725 1448 !- … … 1730 1453 IMPLICIT NONE 1731 1454 !- 1732 INTEGER :: unit, eof,nb_lastkey1455 INTEGER :: unit,eof,nb_lastkey 1733 1456 CHARACTER(LEN=100) :: dummy 1734 1457 CHARACTER(LEN=100) :: out_string … … 1740 1463 !- 1741 1464 DO WHILE (first == "#") 1742 READ ( unit,'(a100)',ERR=9998,END=7778) dummy1465 READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy 1743 1466 dummy = TRIM(ADJUSTL(dummy)) 1744 1467 first=dummy(1:1) … … 1751 1474 RETURN 1752 1475 !- 1753 9998 WRITE(*,*) " GETIN_SKIPAFEW : Error while reading file " 1754 STOP 'getin_skipafew' 1755 !- 1756 7778 eof = 1 1476 9998 CONTINUE 1477 CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') 1478 !- 1479 7778 CONTINUE 1480 eof = 1 1757 1481 !---------------------------- 1758 1482 END SUBROUTINE getin_skipafew 1759 1483 !- 1760 !=== INTEGER database INTERFACE1761 !-1762 SUBROUTINE getdbwi &1763 & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)1764 !---------------------------------------------------------------------1765 !- Write the INTEGER data into the data base1766 !---------------------------------------------------------------------1767 IMPLICIT NONE1768 !-1769 CHARACTER(LEN=*) :: target1770 INTEGER :: target_sig, status, fileorig, size_of_in1771 INTEGER,DIMENSION(:) :: tmp_ret_val1772 !---------------------------------------------------------------------1773 !-1774 ! First check if we have sufficiant space for the new key1775 !-1776 IF (nb_keys+1 > keymemsize) THEN1777 CALL getin_allockeys ()1778 ENDIF1779 !-1780 ! Fill out the items of the data base1781 !-1782 nb_keys = nb_keys+11783 keysig(nb_keys) = target_sig1784 keystr(nb_keys) = target(1:MIN(len_trim(target),30))1785 keystatus(nb_keys) = status1786 keytype(nb_keys) = 11787 keyfromfile(nb_keys) = fileorig1788 !-1789 ! Can we compress the data base entry ?1790 !-1791 IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &1792 & .AND.(size_of_in > compress_lim)) THEN1793 keymemstart(nb_keys) = intmempos+11794 keycompress(nb_keys) = size_of_in1795 keymemlen(nb_keys) = 11796 ELSE1797 keymemstart(nb_keys) = intmempos+11798 keycompress(nb_keys) = -11799 keymemlen(nb_keys) = size_of_in1800 ENDIF1801 !-1802 ! Before writing the actual size lets see if we have the space1803 !-1804 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN1805 CALL getin_allocmem (1,keymemlen(nb_keys))1806 ENDIF1807 !-1808 intmem(keymemstart(nb_keys): &1809 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &1810 & tmp_ret_val(1:keymemlen(nb_keys))1811 intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-11812 !---------------------1813 END SUBROUTINE getdbwi1814 !-1815 !===1816 !-1817 SUBROUTINE getdbri (pos,size_of_in,target,tmp_ret_val)1818 !---------------------------------------------------------------------1819 !- Read the required variables in the database for INTEGERS1820 !---------------------------------------------------------------------1821 IMPLICIT NONE1822 !-1823 INTEGER :: pos, size_of_in1824 CHARACTER(LEN=*) :: target1825 INTEGER,DIMENSION(:) :: tmp_ret_val1826 !---------------------------------------------------------------------1827 IF (keytype(pos) /= 1) THEN1828 WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target1829 STOP 'getdbri'1830 ENDIF1831 !-1832 IF (keycompress(pos) > 0) THEN1833 IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN1834 WRITE(*,*) &1835 & 'FATAL ERROR : Wrong compression length for keyword ',target1836 STOP 'getdbri'1837 ELSE1838 tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos))1839 ENDIF1840 ELSE1841 IF (keymemlen(pos) /= size_of_in) THEN1842 WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target1843 STOP 'getdbri'1844 ELSE1845 tmp_ret_val(1:size_of_in) = &1846 & intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)1847 ENDIF1848 ENDIF1849 !---------------------1850 END SUBROUTINE getdbri1851 !-1852 !=== REAL database INTERFACE1853 !-1854 SUBROUTINE getdbwr &1855 & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)1856 !---------------------------------------------------------------------1857 !- Write the REAL data into the data base1858 !---------------------------------------------------------------------1859 IMPLICIT NONE1860 !-1861 CHARACTER(LEN=*) :: target1862 INTEGER :: target_sig, status, fileorig, size_of_in1863 REAL,DIMENSION(:) :: tmp_ret_val1864 !---------------------------------------------------------------------1865 !-1866 ! First check if we have sufficiant space for the new key1867 !-1868 IF (nb_keys+1 > keymemsize) THEN1869 CALL getin_allockeys ()1870 ENDIF1871 !-1872 ! Fill out the items of the data base1873 !-1874 nb_keys = nb_keys+11875 keysig(nb_keys) = target_sig1876 keystr(nb_keys) = target(1:MIN(len_trim(target),30))1877 keystatus(nb_keys) = status1878 keytype(nb_keys) = 21879 keyfromfile(nb_keys) = fileorig1880 !-1881 ! Can we compress the data base entry ?1882 !-1883 IF ( (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &1884 & .AND.(size_of_in > compress_lim)) THEN1885 keymemstart(nb_keys) = realmempos+11886 keycompress(nb_keys) = size_of_in1887 keymemlen(nb_keys) = 11888 ELSE1889 keymemstart(nb_keys) = realmempos+11890 keycompress(nb_keys) = -11891 keymemlen(nb_keys) = size_of_in1892 ENDIF1893 !-1894 ! Before writing the actual size lets see if we have the space1895 !-1896 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN1897 CALL getin_allocmem (2,keymemlen(nb_keys))1898 ENDIF1899 !-1900 realmem(keymemstart(nb_keys): &1901 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &1902 & tmp_ret_val(1:keymemlen(nb_keys))1903 realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-11904 !---------------------1905 END SUBROUTINE getdbwr1906 !-1907 !===1908 !-1909 SUBROUTINE getdbrr (pos,size_of_in,target,tmp_ret_val)1910 !---------------------------------------------------------------------1911 !- Read the required variables in the database for REALS1912 !---------------------------------------------------------------------1913 IMPLICIT NONE1914 !-1915 INTEGER :: pos, size_of_in1916 CHARACTER(LEN=*) :: target1917 REAL,DIMENSION(:) :: tmp_ret_val1918 !---------------------------------------------------------------------1919 IF (keytype(pos) /= 2) THEN1920 WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target1921 STOP 'getdbrr'1922 ENDIF1923 !-1924 IF (keycompress(pos) > 0) THEN1925 IF ( (keycompress(pos) /= size_of_in) &1926 & .OR.(keymemlen(pos) /= 1) ) THEN1927 WRITE(*,*) &1928 & 'FATAL ERROR : Wrong compression length for keyword ',target1929 STOP 'getdbrr'1930 ELSE1931 tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos))1932 ENDIF1933 ELSE1934 IF (keymemlen(pos) /= size_of_in) THEN1935 WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target1936 STOP 'getdbrr'1937 ELSE1938 tmp_ret_val(1:size_of_in) = &1939 & realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)1940 ENDIF1941 ENDIF1942 !---------------------1943 END SUBROUTINE getdbrr1944 !-1945 !=== CHARACTER database INTERFACE1946 !-1947 SUBROUTINE getdbwc &1948 & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)1949 !---------------------------------------------------------------------1950 !- Write the CHARACTER data into the data base1951 !---------------------------------------------------------------------1952 IMPLICIT NONE1953 !-1954 CHARACTER(LEN=*) :: target1955 INTEGER :: target_sig,status,fileorig,size_of_in1956 CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val1957 !---------------------------------------------------------------------1958 !-1959 ! First check if we have sufficiant space for the new key1960 !-1961 IF (nb_keys+1 > keymemsize) THEN1962 CALL getin_allockeys ()1963 ENDIF1964 !-1965 ! Fill out the items of the data base1966 !-1967 nb_keys = nb_keys+11968 keysig(nb_keys) = target_sig1969 keystr(nb_keys) = target(1:MIN(len_trim(target),30))1970 keystatus(nb_keys) = status1971 keytype(nb_keys) = 31972 keyfromfile(nb_keys) = fileorig1973 keymemstart(nb_keys) = charmempos+11974 keymemlen(nb_keys) = size_of_in1975 !-1976 ! Before writing the actual size lets see if we have the space1977 !-1978 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN1979 CALL getin_allocmem (3,keymemlen(nb_keys))1980 ENDIF1981 !-1982 charmem(keymemstart(nb_keys): &1983 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &1984 & tmp_ret_val(1:keymemlen(nb_keys))1985 charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-11986 !---------------------1987 END SUBROUTINE getdbwc1988 !-1989 !===1990 !-1991 SUBROUTINE getdbrc(pos,size_of_in,target,tmp_ret_val)1992 !---------------------------------------------------------------------1993 !- Read the required variables in the database for CHARACTER1994 !---------------------------------------------------------------------1995 IMPLICIT NONE1996 !-1997 INTEGER :: pos, size_of_in1998 CHARACTER(LEN=*) :: target1999 CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val2000 !---------------------------------------------------------------------2001 IF (keytype(pos) /= 3) THEN2002 WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target2003 STOP 'getdbrc'2004 ENDIF2005 !-2006 IF (keymemlen(pos) /= size_of_in) THEN2007 WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target2008 STOP 'getdbrc'2009 ELSE2010 tmp_ret_val(1:size_of_in) = &2011 & charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)2012 ENDIF2013 !---------------------2014 END SUBROUTINE getdbrc2015 !-2016 !=== LOGICAL database INTERFACE2017 !-2018 SUBROUTINE getdbwl &2019 & (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)2020 !---------------------------------------------------------------------2021 !- Write the LOGICAL data into the data base2022 !---------------------------------------------------------------------2023 IMPLICIT NONE2024 !-2025 CHARACTER(LEN=*) :: target2026 INTEGER :: target_sig, status, fileorig, size_of_in2027 LOGICAL,DIMENSION(:) :: tmp_ret_val2028 !---------------------------------------------------------------------2029 !-2030 ! First check if we have sufficiant space for the new key2031 !-2032 IF (nb_keys+1 > keymemsize) THEN2033 CALL getin_allockeys ()2034 ENDIF2035 !-2036 ! Fill out the items of the data base2037 !-2038 nb_keys = nb_keys+12039 keysig(nb_keys) = target_sig2040 keystr(nb_keys) = target(1:MIN(len_trim(target),30))2041 keystatus(nb_keys) = status2042 keytype(nb_keys) = 42043 keyfromfile(nb_keys) = fileorig2044 keymemstart(nb_keys) = logicmempos+12045 keymemlen(nb_keys) = size_of_in2046 !-2047 ! Before writing the actual size lets see if we have the space2048 !-2049 IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN2050 CALL getin_allocmem (4,keymemlen(nb_keys))2051 ENDIF2052 !-2053 logicmem(keymemstart(nb_keys): &2054 & keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &2055 & tmp_ret_val(1:keymemlen(nb_keys))2056 logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-12057 !---------------------2058 END SUBROUTINE getdbwl2059 !-2060 !===2061 !-2062 SUBROUTINE getdbrl(pos,size_of_in,target,tmp_ret_val)2063 !---------------------------------------------------------------------2064 !- Read the required variables in the database for LOGICALS2065 !---------------------------------------------------------------------2066 IMPLICIT NONE2067 !-2068 INTEGER :: pos, size_of_in2069 CHARACTER(LEN=*) :: target2070 LOGICAL,DIMENSION(:) :: tmp_ret_val2071 !---------------------------------------------------------------------2072 IF (keytype(pos) /= 4) THEN2073 WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target2074 STOP 'getdbrl'2075 ENDIF2076 !-2077 IF (keymemlen(pos) /= size_of_in) THEN2078 WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target2079 STOP 'getdbrl'2080 ELSE2081 tmp_ret_val(1:size_of_in) = &2082 & logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)2083 ENDIF2084 !---------------------2085 END SUBROUTINE getdbrl2086 !-2087 1484 !=== 2088 1485 !- … … 2095 1492 !- 2096 1493 INTEGER :: ier 1494 CHARACTER(LEN=20) :: c_tmp 2097 1495 !--------------------------------------------------------------------- 2098 1496 !- … … 2100 1498 !- 2101 1499 IF (keymemsize == 0) THEN 2102 !- 1500 !--- 1501 WRITE (UNIT=c_tmp,FMT=*) memslabs 1502 !--- 2103 1503 ALLOCATE(keysig(memslabs),stat=ier) 2104 1504 IF (ier /= 0) THEN 2105 WRITE(*,*) & 2106 & 'getin_allockeys : Can not allocate keysig to size ', & 2107 & memslabs 2108 STOP 2109 ENDIF 2110 !- 1505 CALL ipslerr (3,'getin_allockeys', & 1506 & 'Can not allocate keysig', & 1507 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1508 ENDIF 1509 !--- 2111 1510 ALLOCATE(keystr(memslabs),stat=ier) 2112 1511 IF (ier /= 0) THEN 2113 WRITE(*,*) & 2114 & 'getin_allockeys : Can not allocate keystr to size ', & 2115 & memslabs 2116 STOP 2117 ENDIF 2118 !- 1512 CALL ipslerr (3,'getin_allockeys', & 1513 & 'Can not allocate keystr', & 1514 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1515 ENDIF 1516 !--- 2119 1517 ALLOCATE(keystatus(memslabs),stat=ier) 2120 1518 IF (ier /= 0) THEN 2121 WRITE(*,*) & 2122 & 'getin_allockeys : Can not allocate keystatus to size ', & 2123 & memslabs 2124 STOP 2125 ENDIF 2126 !- 1519 CALL ipslerr (3,'getin_allockeys', & 1520 & 'Can not allocate keystatus', & 1521 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1522 ENDIF 1523 !--- 2127 1524 ALLOCATE(keytype(memslabs),stat=ier) 2128 1525 IF (ier /= 0) THEN 2129 WRITE(*,*) & 2130 & 'getin_allockeys : Can not allocate keytype to size ', & 2131 & memslabs 2132 STOP 2133 ENDIF 2134 !- 1526 CALL ipslerr (3,'getin_allockeys', & 1527 & 'Can not allocate keytype', & 1528 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1529 ENDIF 1530 !--- 2135 1531 ALLOCATE(keycompress(memslabs),stat=ier) 2136 1532 IF (ier /= 0) THEN 2137 WRITE(*,*) & 2138 & 'getin_allockeys : Can not allocate keycompress to size ', & 2139 & memslabs 2140 STOP 2141 ENDIF 2142 !- 1533 CALL ipslerr (3,'getin_allockeys', & 1534 & 'Can not allocate keycompress', & 1535 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1536 ENDIF 1537 !--- 2143 1538 ALLOCATE(keyfromfile(memslabs),stat=ier) 2144 1539 IF (ier /= 0) THEN 2145 WRITE(*,*) & 2146 & 'getin_allockeys : Can not allocate keyfromfile to size ', & 2147 & memslabs 2148 STOP 2149 ENDIF 2150 !- 1540 CALL ipslerr (3,'getin_allockeys', & 1541 & 'Can not allocate keyfromfile', & 1542 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1543 ENDIF 1544 !--- 2151 1545 ALLOCATE(keymemstart(memslabs),stat=ier) 2152 1546 IF (ier /= 0) THEN 2153 WRITE(*,*) & 2154 & 'getin_allockeys : Can not allocate keymemstart to size ', & 2155 & memslabs 2156 STOP 2157 ENDIF 2158 !- 1547 CALL ipslerr (3,'getin_allockeys', & 1548 & 'Can not allocate keymemstart', & 1549 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1550 ENDIF 1551 !--- 2159 1552 ALLOCATE(keymemlen(memslabs),stat=ier) 2160 1553 IF (ier /= 0) THEN 2161 WRITE(*,*) & 2162 & 'getin_allockeys : Can not allocate keymemlen to size ', & 2163 & memslabs 2164 STOP 2165 ENDIF 2166 !- 1554 CALL ipslerr (3,'getin_allockeys', & 1555 & 'Can not allocate keymemlen', & 1556 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1557 ENDIF 1558 !--- 2167 1559 nb_keys = 0 2168 1560 keymemsize = memslabs 2169 1561 keycompress(:) = -1 2170 !- 1562 !--- 2171 1563 ELSE 2172 !- 1564 !--- 2173 1565 !-- There is something already in the memory, 2174 1566 !-- we need to transfer and reallocate. 2175 !- 1567 !--- 1568 WRITE (UNIT=c_tmp,FMT=*) keymemsize 1569 !--- 2176 1570 ALLOCATE(tmp_str(keymemsize),stat=ier) 2177 1571 IF (ier /= 0) THEN 2178 WRITE(*,*) & 2179 & 'getin_allockeys : Can not allocate tmp_str to size ', & 2180 & keymemsize 2181 STOP 2182 ENDIF 2183 !- 1572 CALL ipslerr (3,'getin_allockeys', & 1573 & 'Can not allocate tmp_str', & 1574 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1575 ENDIF 1576 !--- 2184 1577 ALLOCATE(tmp_int(keymemsize),stat=ier) 2185 1578 IF (ier /= 0) THEN 2186 WRITE(*,*) & 2187 & 'getin_allockeys : Can not allocate tmp_int to size ', & 2188 & keymemsize 2189 STOP 2190 ENDIF 2191 !- 1579 CALL ipslerr (3,'getin_allockeys', & 1580 & 'Can not allocate tmp_int', & 1581 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1582 ENDIF 1583 !--- 1584 WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs 1585 !--- 2192 1586 tmp_int(1:keymemsize) = keysig(1:keymemsize) 2193 1587 DEALLOCATE(keysig) 2194 1588 ALLOCATE(keysig(keymemsize+memslabs),stat=ier) 2195 1589 IF (ier /= 0) THEN 2196 WRITE(*,*) & 2197 & 'getin_allockeys : Can not allocate keysig to size ', & 2198 & keymemsize+memslabs 2199 STOP 1590 CALL ipslerr (3,'getin_allockeys', & 1591 & 'Can not allocate keysig', & 1592 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2200 1593 ENDIF 2201 1594 keysig(1:keymemsize) = tmp_int(1:keymemsize) 2202 !- 1595 !--- 2203 1596 tmp_str(1:keymemsize) = keystr(1:keymemsize) 2204 1597 DEALLOCATE(keystr) 2205 1598 ALLOCATE(keystr(keymemsize+memslabs),stat=ier) 2206 1599 IF (ier /= 0) THEN 2207 WRITE(*,*) & 2208 & 'getin_allockeys : Can not allocate keystr to size ', & 2209 & keymemsize+memslabs 2210 STOP 1600 CALL ipslerr (3,'getin_allockeys', & 1601 & 'Can not allocate keystr', & 1602 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2211 1603 ENDIF 2212 1604 keystr(1:keymemsize) = tmp_str(1:keymemsize) 2213 !- 1605 !--- 2214 1606 tmp_int(1:keymemsize) = keystatus(1:keymemsize) 2215 1607 DEALLOCATE(keystatus) 2216 1608 ALLOCATE(keystatus(keymemsize+memslabs),stat=ier) 2217 1609 IF (ier /= 0) THEN 2218 WRITE(*,*) & 2219 & 'getin_allockeys : Can not allocate keystatus to size ', & 2220 & keymemsize+memslabs 2221 STOP 1610 CALL ipslerr (3,'getin_allockeys', & 1611 & 'Can not allocate keystatus', & 1612 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2222 1613 ENDIF 2223 1614 keystatus(1:keymemsize) = tmp_int(1:keymemsize) 2224 !- 1615 !--- 2225 1616 tmp_int(1:keymemsize) = keytype(1:keymemsize) 2226 1617 DEALLOCATE(keytype) 2227 1618 ALLOCATE(keytype(keymemsize+memslabs),stat=ier) 2228 1619 IF (ier /= 0) THEN 2229 WRITE(*,*) & 2230 & 'getin_allockeys : Can not allocate keytype to size ', & 2231 & keymemsize+memslabs 2232 STOP 1620 CALL ipslerr (3,'getin_allockeys', & 1621 & 'Can not allocate keytype', & 1622 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2233 1623 ENDIF 2234 1624 keytype(1:keymemsize) = tmp_int(1:keymemsize) 2235 !- 1625 !--- 2236 1626 tmp_int(1:keymemsize) = keycompress(1:keymemsize) 2237 1627 DEALLOCATE(keycompress) 2238 1628 ALLOCATE(keycompress(keymemsize+memslabs),stat=ier) 2239 1629 IF (ier /= 0) THEN 2240 WRITE(*,*) & 2241 & 'getin_allockeys : Can not allocate keycompress to size ', & 2242 & keymemsize+memslabs 2243 STOP 1630 CALL ipslerr (3,'getin_allockeys', & 1631 & 'Can not allocate keycompress', & 1632 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2244 1633 ENDIF 2245 1634 keycompress(:) = -1 2246 1635 keycompress(1:keymemsize) = tmp_int(1:keymemsize) 2247 !- 1636 !--- 2248 1637 tmp_int(1:keymemsize) = keyfromfile(1:keymemsize) 2249 1638 DEALLOCATE(keyfromfile) 2250 1639 ALLOCATE(keyfromfile(keymemsize+memslabs),stat=ier) 2251 1640 IF (ier /= 0) THEN 2252 WRITE(*,*) & 2253 & 'getin_allockeys : Can not allocate keyfromfile to size ', & 2254 & keymemsize+memslabs 2255 STOP 1641 CALL ipslerr (3,'getin_allockeys', & 1642 & 'Can not allocate keyfromfile', & 1643 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2256 1644 ENDIF 2257 1645 keyfromfile(1:keymemsize) = tmp_int(1:keymemsize) 2258 !- 1646 !--- 2259 1647 tmp_int(1:keymemsize) = keymemstart(1:keymemsize) 2260 1648 DEALLOCATE(keymemstart) 2261 1649 ALLOCATE(keymemstart(keymemsize+memslabs),stat=ier) 2262 1650 IF (ier /= 0) THEN 2263 WRITE(*,*) & 2264 & 'getin_allockeys : Can not allocate keymemstart to size ', & 2265 & keymemsize+memslabs 2266 STOP 1651 CALL ipslerr (3,'getin_allockeys', & 1652 & 'Can not allocate keymemstart', & 1653 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2267 1654 ENDIF 2268 1655 keymemstart(1:keymemsize) = tmp_int(1:keymemsize) 2269 !- 1656 !--- 2270 1657 tmp_int(1:keymemsize) = keymemlen(1:keymemsize) 2271 1658 DEALLOCATE(keymemlen) 2272 1659 ALLOCATE(keymemlen(keymemsize+memslabs),stat=ier) 2273 1660 IF (ier /= 0) THEN 2274 WRITE(*,*) & 2275 & 'getin_allockeys : Can not allocate keymemlen to size ', & 2276 & keymemsize+memslabs 2277 STOP 1661 CALL ipslerr (3,'getin_allockeys', & 1662 & 'Can not allocate keymemlen', & 1663 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 2278 1664 ENDIF 2279 1665 keymemlen(1:keymemsize) = tmp_int(1:keymemsize) 2280 !- 1666 !--- 2281 1667 keymemsize = keymemsize+memslabs 2282 !- 1668 !--- 2283 1669 DEALLOCATE(tmp_int) 2284 1670 DEALLOCATE(tmp_str) … … 2292 1678 !--------------------------------------------------------------------- 2293 1679 !- Allocate the memory of the data base for all 4 types of memory 2294 !- 2295 !- 1 = INTEGER 2296 !- 2 = REAL 2297 !- 3 = CHAR 2298 !- 4 = LOGICAL 2299 !--------------------------------------------------------------------- 2300 IMPLICIT NONE 2301 !- 2302 INTEGER :: type, len_wanted 1680 !- INTEGER / REAL / CHAR / LOGICAL 1681 !--------------------------------------------------------------------- 1682 IMPLICIT NONE 1683 !- 1684 INTEGER :: type,len_wanted 2303 1685 !- 2304 1686 INTEGER,ALLOCATABLE :: tmp_int(:) … … 2307 1689 LOGICAL,ALLOCATABLE :: tmp_logic(:) 2308 1690 INTEGER :: ier 1691 CHARACTER(LEN=20) :: c_tmp 2309 1692 !--------------------------------------------------------------------- 2310 1693 SELECT CASE (type) 2311 CASE( 1)2312 IF (i ntmemsize == 0) THEN2313 ALLOCATE(i ntmem(memslabs),stat=ier)1694 CASE(k_i) 1695 IF (i_memsize == 0) THEN 1696 ALLOCATE(i_mem(memslabs),stat=ier) 2314 1697 IF (ier /= 0) THEN 2315 WRITE (*,*) &2316 & 'getin_allocmem : Unable to allocate db-memory intmem to', &2317 & memslabs2318 STOP2319 ENDIF 2320 i ntmemsize=memslabs1698 WRITE (UNIT=c_tmp,FMT=*) memslabs 1699 CALL ipslerr (3,'getin_allocmem', & 1700 & 'Unable to allocate db-memory', & 1701 & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1702 ENDIF 1703 i_memsize=memslabs 2321 1704 ELSE 2322 ALLOCATE(tmp_int(i ntmemsize),stat=ier)1705 ALLOCATE(tmp_int(i_memsize),stat=ier) 2323 1706 IF (ier /= 0) THEN 2324 WRITE (*,*) &2325 & 'getin_allocmem : Unable to allocate tmp_int to', &2326 & intmemsize2327 STOP2328 ENDIF 2329 tmp_int(1:i ntmemsize) = intmem(1:intmemsize)2330 DEALLOCATE(i ntmem)2331 ALLOCATE(i ntmem(intmemsize+MAX(memslabs,len_wanted)),stat=ier)1707 WRITE (UNIT=c_tmp,FMT=*) i_memsize 1708 CALL ipslerr (3,'getin_allocmem', & 1709 & 'Unable to allocate tmp_int', & 1710 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1711 ENDIF 1712 tmp_int(1:i_memsize) = i_mem(1:i_memsize) 1713 DEALLOCATE(i_mem) 1714 ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) 2332 1715 IF (ier /= 0) THEN 2333 WRITE (*,*) &2334 & 'getin_allocmem : Unable to re-allocate db-memory intmem to', &2335 & intmemsize+MAX(memslabs,len_wanted)2336 STOP2337 ENDIF 2338 i ntmem(1:intmemsize) = tmp_int(1:intmemsize)2339 i ntmemsize = intmemsize+MAX(memslabs,len_wanted)1716 WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) 1717 CALL ipslerr (3,'getin_allocmem', & 1718 & 'Unable to re-allocate db-memory', & 1719 & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1720 ENDIF 1721 i_mem(1:i_memsize) = tmp_int(1:i_memsize) 1722 i_memsize = i_memsize+MAX(memslabs,len_wanted) 2340 1723 DEALLOCATE(tmp_int) 2341 1724 ENDIF 2342 CASE( 2)2343 IF (r ealmemsize == 0) THEN2344 ALLOCATE(r ealmem(memslabs),stat=ier)1725 CASE(k_r) 1726 IF (r_memsize == 0) THEN 1727 ALLOCATE(r_mem(memslabs),stat=ier) 2345 1728 IF (ier /= 0) THEN 2346 WRITE (*,*) &2347 & 'getin_allocmem : Unable to allocate db-memory realmem to', &2348 & memslabs2349 STOP2350 ENDIF 2351 r ealmemsize = memslabs1729 WRITE (UNIT=c_tmp,FMT=*) memslabs 1730 CALL ipslerr (3,'getin_allocmem', & 1731 & 'Unable to allocate db-memory', & 1732 & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1733 ENDIF 1734 r_memsize = memslabs 2352 1735 ELSE 2353 ALLOCATE(tmp_real(r ealmemsize),stat=ier)1736 ALLOCATE(tmp_real(r_memsize),stat=ier) 2354 1737 IF (ier /= 0) THEN 2355 WRITE (*,*) &2356 & 'getin_allocmem : Unable to allocate tmp_real to', &2357 & realmemsize2358 STOP2359 ENDIF 2360 tmp_real(1:r ealmemsize) = realmem(1:realmemsize)2361 DEALLOCATE(r ealmem)2362 ALLOCATE(r ealmem(realmemsize+MAX(memslabs,len_wanted)),stat=ier)1738 WRITE (UNIT=c_tmp,FMT=*) r_memsize 1739 CALL ipslerr (3,'getin_allocmem', & 1740 & 'Unable to allocate tmp_real', & 1741 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1742 ENDIF 1743 tmp_real(1:r_memsize) = r_mem(1:r_memsize) 1744 DEALLOCATE(r_mem) 1745 ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) 2363 1746 IF (ier /= 0) THEN 2364 WRITE (*,*) &2365 & 'getin_allocmem : Unable to re-allocate db-memory realmem to', &2366 & realmemsize+MAX(memslabs,len_wanted)2367 STOP2368 ENDIF 2369 r ealmem(1:realmemsize) = tmp_real(1:realmemsize)2370 r ealmemsize = realmemsize+MAX(memslabs,len_wanted)1747 WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) 1748 CALL ipslerr (3,'getin_allocmem', & 1749 & 'Unable to re-allocate db-memory', & 1750 & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1751 ENDIF 1752 r_mem(1:r_memsize) = tmp_real(1:r_memsize) 1753 r_memsize = r_memsize+MAX(memslabs,len_wanted) 2371 1754 DEALLOCATE(tmp_real) 2372 1755 ENDIF 2373 CASE( 3)2374 IF (c harmemsize == 0) THEN2375 ALLOCATE(c harmem(memslabs),stat=ier)1756 CASE(k_c) 1757 IF (c_memsize == 0) THEN 1758 ALLOCATE(c_mem(memslabs),stat=ier) 2376 1759 IF (ier /= 0) THEN 2377 WRITE (*,*) &2378 & 'getin_allocmem : Unable to allocate db-memory charmem to', &2379 & memslabs2380 STOP2381 ENDIF 2382 c harmemsize = memslabs1760 WRITE (UNIT=c_tmp,FMT=*) memslabs 1761 CALL ipslerr (3,'getin_allocmem', & 1762 & 'Unable to allocate db-memory', & 1763 & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1764 ENDIF 1765 c_memsize = memslabs 2383 1766 ELSE 2384 ALLOCATE(tmp_char(c harmemsize),stat=ier)1767 ALLOCATE(tmp_char(c_memsize),stat=ier) 2385 1768 IF (ier /= 0) THEN 2386 WRITE (*,*) &2387 & 'getin_allocmem : Unable to allocate tmp_char to', &2388 & charmemsize2389 STOP2390 ENDIF 2391 tmp_char(1:c harmemsize) = charmem(1:charmemsize)2392 DEALLOCATE(c harmem)2393 ALLOCATE(c harmem(charmemsize+MAX(memslabs,len_wanted)),stat=ier)1769 WRITE (UNIT=c_tmp,FMT=*) c_memsize 1770 CALL ipslerr (3,'getin_allocmem', & 1771 & 'Unable to allocate tmp_char', & 1772 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1773 ENDIF 1774 tmp_char(1:c_memsize) = c_mem(1:c_memsize) 1775 DEALLOCATE(c_mem) 1776 ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) 2394 1777 IF (ier /= 0) THEN 2395 WRITE (*,*) &2396 & 'getin_allocmem : Unable to re-allocate db-memory charmem to', &2397 & charmemsize+MAX(memslabs,len_wanted)2398 STOP2399 ENDIF 2400 c harmem(1:charmemsize) = tmp_char(1:charmemsize)2401 c harmemsize = charmemsize+MAX(memslabs,len_wanted)1778 WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) 1779 CALL ipslerr (3,'getin_allocmem', & 1780 & 'Unable to re-allocate db-memory', & 1781 & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1782 ENDIF 1783 c_mem(1:c_memsize) = tmp_char(1:c_memsize) 1784 c_memsize = c_memsize+MAX(memslabs,len_wanted) 2402 1785 DEALLOCATE(tmp_char) 2403 1786 ENDIF 2404 CASE( 4)2405 IF (l ogicmemsize == 0) THEN2406 ALLOCATE(l ogicmem(memslabs),stat=ier)1787 CASE(k_l) 1788 IF (l_memsize == 0) THEN 1789 ALLOCATE(l_mem(memslabs),stat=ier) 2407 1790 IF (ier /= 0) THEN 2408 WRITE (*,*) &2409 & 'getin_allocmem : Unable to allocate db-memory logicmem to', &2410 & memslabs2411 STOP2412 ENDIF 2413 l ogicmemsize = memslabs1791 WRITE (UNIT=c_tmp,FMT=*) memslabs 1792 CALL ipslerr (3,'getin_allocmem', & 1793 & 'Unable to allocate db-memory', & 1794 & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1795 ENDIF 1796 l_memsize = memslabs 2414 1797 ELSE 2415 ALLOCATE(tmp_logic(l ogicmemsize),stat=ier)1798 ALLOCATE(tmp_logic(l_memsize),stat=ier) 2416 1799 IF (ier /= 0) THEN 2417 WRITE (*,*) &2418 & 'getin_allocmem : Unable to allocate tmp_logic to', &2419 & logicmemsize2420 STOP2421 ENDIF 2422 tmp_logic(1:l ogicmemsize) = logicmem(1:logicmemsize)2423 DEALLOCATE(l ogicmem)2424 ALLOCATE(l ogicmem(logicmemsize+MAX(memslabs,len_wanted)),stat=ier)1800 WRITE (UNIT=c_tmp,FMT=*) l_memsize 1801 CALL ipslerr (3,'getin_allocmem', & 1802 & 'Unable to allocate tmp_logic', & 1803 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1804 ENDIF 1805 tmp_logic(1:l_memsize) = l_mem(1:l_memsize) 1806 DEALLOCATE(l_mem) 1807 ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) 2425 1808 IF (ier /= 0) THEN 2426 WRITE (*,*) &2427 & 'getin_allocmem : Unable to re-allocate db-memory logicmem to', &2428 & logicmemsize+MAX(memslabs,len_wanted)2429 STOP2430 ENDIF 2431 l ogicmem(1:logicmemsize) = tmp_logic(1:logicmemsize)2432 l ogicmemsize = logicmemsize+MAX(memslabs,len_wanted)1809 WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) 1810 CALL ipslerr (3,'getin_allocmem', & 1811 & 'Unable to re-allocate db-memory', & 1812 & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1813 ENDIF 1814 l_mem(1:l_memsize) = tmp_logic(1:l_memsize) 1815 l_memsize = l_memsize+MAX(memslabs,len_wanted) 2433 1816 DEALLOCATE(tmp_logic) 2434 1817 ENDIF 2435 1818 CASE DEFAULT 2436 WRITE(*,*) 'getin_allocmem : Unknown type : ',type 2437 STOP 1819 CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') 2438 1820 END SELECT 2439 1821 !---------------------------- … … 2456 1838 CHARACTER(*),OPTIONAL :: fileprefix 2457 1839 !- 2458 CHARACTER(LEN=80) :: usedfileprefix = "used"1840 CHARACTER(LEN=80) :: usedfileprefix 2459 1841 INTEGER :: ikey,if,iff,iv 2460 CHARACTER(LEN= 3) :: tmp32461 CHARACTER(LEN=100) :: tmp_str, 1842 CHARACTER(LEN=20) :: c_tmp 1843 CHARACTER(LEN=100) :: tmp_str,used_filename 2462 1844 LOGICAL :: check = .FALSE. 2463 1845 !--------------------------------------------------------------------- 2464 1846 IF (PRESENT(fileprefix)) THEN 2465 usedfileprefix = fileprefix(1:MIN(len_trim(fileprefix),80)) 1847 usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) 1848 ELSE 1849 usedfileprefix = "used" 2466 1850 ENDIF 2467 1851 !- … … 2474 1858 WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys 2475 1859 ENDIF 2476 OPEN (unit=76,file=used_filename)2477 !- 1860 OPEN (UNIT=22,FILE=used_filename) 1861 !--- 2478 1862 !-- If this is the first file we need to add the list 2479 1863 !-- of file which belong to it 2480 !- 2481 IF ( (if == 1) .AND. (nbfiles > 1) ) THEN 2482 WRITE(76,*) '# ' 2483 WRITE(76,*) '# This file is linked to the following files :' 2484 WRITE(76,*) '# ' 1864 IF ( (if == 1).AND.(nbfiles > 1) ) THEN 1865 WRITE(22,*) '# ' 1866 WRITE(22,*) '# This file is linked to the following files :' 1867 WRITE(22,*) '# ' 2485 1868 DO iff=2,nbfiles 2486 WRITE( 76,*) 'INCLUDEDEF = ',TRIM(filelist(iff))1869 WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) 2487 1870 ENDDO 2488 WRITE( 76,*) '# '1871 WRITE(22,*) '# ' 2489 1872 ENDIF 2490 1873 !--- 2491 1874 DO ikey=1,nb_keys 2492 !- 2493 !---- Is this key form this file ? 2494 !- 1875 !----- 1876 !---- Is this key from this file ? 2495 1877 IF (keyfromfile(ikey) == if) THEN 2496 !- 2497 !---- Write some comments 2498 !- 2499 WRITE(76,*) '#' 1878 !------- 1879 !------ Write some comments 1880 WRITE(22,*) '#' 2500 1881 SELECT CASE (keystatus(ikey)) 2501 1882 CASE(1) 2502 WRITE( 76,*) '# Values of ', &1883 WRITE(22,*) '# Values of ', & 2503 1884 & TRIM(keystr(ikey)),' comes from the run.def.' 2504 1885 CASE(2) 2505 WRITE( 76,*) '# Values of ', &1886 WRITE(22,*) '# Values of ', & 2506 1887 & TRIM(keystr(ikey)),' are all defaults.' 2507 1888 CASE(3) 2508 WRITE( 76,*) '# Values of ', &1889 WRITE(22,*) '# Values of ', & 2509 1890 & TRIM(keystr(ikey)),' are a mix of run.def and defaults.' 2510 1891 CASE DEFAULT 2511 WRITE( 76,*) '# Dont know from where the value of ', &1892 WRITE(22,*) '# Dont know from where the value of ', & 2512 1893 & TRIM(keystr(ikey)),' comes.' 2513 1894 END SELECT 2514 WRITE(76,*) '#' 2515 !- 2516 !---- Write the values 2517 !- 1895 WRITE(22,*) '#' 1896 !------- 1897 !------ Write the values 2518 1898 SELECT CASE (keytype(ikey)) 2519 !- 2520 CASE(1) 1899 CASE(k_i) 2521 1900 IF (keymemlen(ikey) == 1) THEN 2522 1901 IF (keycompress(ikey) < 0) THEN 2523 WRITE( 76,*) &2524 & TRIM(keystr(ikey)),' = ',i ntmem(keymemstart(ikey))1902 WRITE(22,*) & 1903 & TRIM(keystr(ikey)),' = ',i_mem(keymemstart(ikey)) 2525 1904 ELSE 2526 WRITE( 76,*) &1905 WRITE(22,*) & 2527 1906 & TRIM(keystr(ikey)),' = ',keycompress(ikey), & 2528 & ' * ',i ntmem(keymemstart(ikey))1907 & ' * ',i_mem(keymemstart(ikey)) 2529 1908 ENDIF 2530 1909 ELSE 2531 1910 DO iv=0,keymemlen(ikey)-1 2532 WRITE( tmp3,'(I3.3)') iv+12533 WRITE( 76,*) &2534 & TRIM(keystr(ikey)),'__', tmp3, &2535 & ' = ',i ntmem(keymemstart(ikey)+iv)1911 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1912 WRITE(22,*) & 1913 & TRIM(keystr(ikey)),'__',TRIM(ADJUSTL(c_tmp)), & 1914 & ' = ',i_mem(keymemstart(ikey)+iv) 2536 1915 ENDDO 2537 1916 ENDIF 2538 !- 2539 CASE(2) 1917 CASE(k_r) 2540 1918 IF (keymemlen(ikey) == 1) THEN 2541 1919 IF (keycompress(ikey) < 0) THEN 2542 WRITE( 76,*) &2543 & TRIM(keystr(ikey)),' = ',r ealmem(keymemstart(ikey))1920 WRITE(22,*) & 1921 & TRIM(keystr(ikey)),' = ',r_mem(keymemstart(ikey)) 2544 1922 ELSE 2545 WRITE( 76,*) &1923 WRITE(22,*) & 2546 1924 & TRIM(keystr(ikey)),' = ',keycompress(ikey),& 2547 & ' * ',r ealmem(keymemstart(ikey))1925 & ' * ',r_mem(keymemstart(ikey)) 2548 1926 ENDIF 2549 1927 ELSE 2550 1928 DO iv=0,keymemlen(ikey)-1 2551 WRITE( tmp3,'(I3.3)') iv+12552 WRITE( 76,*) &2553 & TRIM(keystr(ikey)),'__', tmp3, &2554 & ' = ',r ealmem(keymemstart(ikey)+iv)1929 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1930 WRITE(22,*) & 1931 & TRIM(keystr(ikey)),'__',TRIM(ADJUSTL(c_tmp)), & 1932 & ' = ',r_mem(keymemstart(ikey)+iv) 2555 1933 ENDDO 2556 1934 ENDIF 2557 CASE( 3)1935 CASE(k_c) 2558 1936 IF (keymemlen(ikey) == 1) THEN 2559 tmp_str = c harmem(keymemstart(ikey))2560 WRITE( 76,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str)1937 tmp_str = c_mem(keymemstart(ikey)) 1938 WRITE(22,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str) 2561 1939 ELSE 2562 1940 DO iv=0,keymemlen(ikey)-1 2563 WRITE(tmp3,'(I3.3)') iv+1 2564 tmp_str = charmem(keymemstart(ikey)+iv) 2565 WRITE(76,*) & 2566 & TRIM(keystr(ikey)),'__',tmp3,' = ',TRIM(tmp_str) 1941 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1942 tmp_str = c_mem(keymemstart(ikey)+iv) 1943 WRITE(22,*) & 1944 & TRIM(keystr(ikey)),'__',TRIM(ADJUSTL(c_tmp)), & 1945 & ' = ',TRIM(tmp_str) 2567 1946 ENDDO 2568 1947 ENDIF 2569 CASE( 4)1948 CASE(k_l) 2570 1949 IF (keymemlen(ikey) == 1) THEN 2571 IF (l ogicmem(keymemstart(ikey))) THEN2572 WRITE( 76,*) TRIM(keystr(ikey)),' = TRUE '1950 IF (l_mem(keymemstart(ikey))) THEN 1951 WRITE(22,*) TRIM(keystr(ikey)),' = TRUE ' 2573 1952 ELSE 2574 WRITE( 76,*) TRIM(keystr(ikey)),' = FALSE '1953 WRITE(22,*) TRIM(keystr(ikey)),' = FALSE ' 2575 1954 ENDIF 2576 1955 ELSE 2577 1956 DO iv=0,keymemlen(ikey)-1 2578 WRITE(tmp3,'(I3.3)') iv+1 2579 IF (logicmem(keymemstart(ikey)+iv)) THEN 2580 WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = TRUE ' 1957 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1958 IF (l_mem(keymemstart(ikey)+iv)) THEN 1959 WRITE(22,*) TRIM(keystr(ikey)),'__', & 1960 & TRIM(ADJUSTL(c_tmp)),' = TRUE ' 2581 1961 ELSE 2582 WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = FALSE ' 1962 WRITE(22,*) TRIM(keystr(ikey)),'__', & 1963 & TRIM(ADJUSTL(c_tmp)),' = FALSE ' 2583 1964 ENDIF 2584 1965 ENDDO 2585 1966 ENDIF 2586 !-2587 1967 CASE DEFAULT 2588 WRITE(*,*) & 2589 & 'FATAL ERROR : Unknown type for variable ', & 2590 & TRIM(keystr(ikey)) 2591 STOP 'getin_dump' 1968 CALL ipslerr (3,'getin_dump', & 1969 & 'Unknown type for variable '//TRIM(keystr(ikey)),' ',' ') 2592 1970 END SELECT 2593 1971 ENDIF 2594 1972 ENDDO 2595 1973 !- 2596 CLOSE( unit=76)1974 CLOSE(UNIT=22) 2597 1975 !- 2598 1976 ENDDO 2599 1977 !------------------------ 2600 1978 END SUBROUTINE getin_dump 2601 !-2602 1979 !=== 2603 !- 1980 SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) 1981 !--------------------------------------------------------------------- 1982 !- Returns the type of the argument (mutually exclusive) 1983 !--------------------------------------------------------------------- 1984 IMPLICIT NONE 1985 !- 1986 INTEGER,INTENT(OUT) :: k_typ 1987 CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp 1988 INTEGER,DIMENSION(:),OPTIONAL :: i_v 1989 REAL,DIMENSION(:),OPTIONAL :: r_v 1990 LOGICAL,DIMENSION(:),OPTIONAL :: l_v 1991 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v 1992 !--------------------------------------------------------------------- 1993 k_typ = 0 1994 IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & 1995 & /= 1) THEN 1996 CALL ipslerr (3,'get_qtyp', & 1997 & 'Invalid number of optional arguments','(/= 1)',' ') 1998 ENDIF 1999 !- 2000 IF (PRESENT(i_v)) THEN 2001 k_typ = k_i 2002 c_vtyp = 'INTEGER' 2003 ELSEIF (PRESENT(r_v)) THEN 2004 k_typ = k_r 2005 c_vtyp = 'REAL' 2006 ELSEIF (PRESENT(c_v)) THEN 2007 k_typ = k_c 2008 c_vtyp = 'CHARACTER' 2009 ELSEIF (PRESENT(l_v)) THEN 2010 k_typ = k_l 2011 c_vtyp = 'LOGICAL' 2012 ENDIF 2013 !---------------------- 2014 END SUBROUTINE get_qtyp 2015 !=== 2016 !------------------ 2604 2017 END MODULE getincom
Note: See TracChangeset
for help on using the changeset viewer.