- Timestamp:
- 02/21/11 15:08:02 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/getincom.f90
r963 r1313 6 6 ! See IOIPSL/IOIPSL_License_CeCILL.txt 7 7 !--------------------------------------------------------------------- 8 USE errioipsl, ONLY : ipslerr 8 USE errioipsl, ONLY : ipslerr,ipsldbg 9 9 USE stringop, & 10 10 & ONLY : nocomma,cmpblank,strlowercase … … 35 35 !! and if not we get it from the definition file. 36 36 !! 37 !! SUBROUTINE getin (target ,ret_val)37 !! SUBROUTINE getin (targetname,ret_val) 38 38 !! 39 39 !! INPUT 40 40 !! 41 !! (C) target : Name of the variable41 !! (C) targetname : Name of the variable 42 42 !! 43 43 !! OUTPUT … … 98 98 ! keystatus = 2 : Default value is used 99 99 ! keystatus = 3 : Some vector elements were taken from default 100 INTEGER,PARAMETER :: nondefault=1, default=2, vectornondefault=3 100 101 !- 101 102 ! keytype definition … … 150 151 !=== INTEGER INTERFACE 151 152 !- 152 SUBROUTINE getinis (target ,ret_val)153 !--------------------------------------------------------------------- 154 IMPLICIT NONE 155 !- 156 CHARACTER(LEN=*) :: target 153 SUBROUTINE getinis (targetname,ret_val) 154 !--------------------------------------------------------------------- 155 IMPLICIT NONE 156 !- 157 CHARACTER(LEN=*) :: targetname 157 158 INTEGER :: ret_val 158 159 !- 159 160 INTEGER,DIMENSION(1) :: tmp_ret_val 160 INTEGER :: pos,status=0,fileorig 161 !--------------------------------------------------------------------- 162 !- 163 ! Do we have this target in our database ?164 !- 165 CALL get_findkey (1,target ,pos)161 INTEGER :: pos,status=0,fileorig, size_of_in 162 !--------------------------------------------------------------------- 163 !- 164 ! Do we have this targetname in our database ? 165 !- 166 CALL get_findkey (1,targetname,pos) 166 167 !- 167 168 tmp_ret_val(1) = ret_val 169 size_of_in = SIZE(tmp_ret_val) 170 168 171 !- 169 172 IF (pos < 0) THEN 170 173 !-- Get the information out of the file 171 CALL get_fil (target ,status,fileorig,i_val=tmp_ret_val)174 CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val) 172 175 !-- Put the data into the database 173 176 CALL get_wdb & 174 & (target ,status,fileorig,1,i_val=tmp_ret_val)177 & (targetname,status,fileorig,1,i_val=tmp_ret_val) 175 178 ELSE 176 179 !-- Get the value out of the database 177 CALL get_rdb (pos,1,target ,i_val=tmp_ret_val)180 CALL get_rdb (pos,1,targetname,i_val=tmp_ret_val) 178 181 ENDIF 179 182 ret_val = tmp_ret_val(1) … … 181 184 END SUBROUTINE getinis 182 185 !=== 183 SUBROUTINE getini1d (target ,ret_val)184 !--------------------------------------------------------------------- 185 IMPLICIT NONE 186 !- 187 CHARACTER(LEN=*) :: target 186 SUBROUTINE getini1d (targetname,ret_val) 187 !--------------------------------------------------------------------- 188 IMPLICIT NONE 189 !- 190 CHARACTER(LEN=*) :: targetname 188 191 INTEGER,DIMENSION(:) :: ret_val 189 192 !- … … 193 196 !--------------------------------------------------------------------- 194 197 !- 195 ! Do we have this target in our database ?196 !- 197 CALL get_findkey (1,target ,pos)198 ! Do we have this targetname in our database ? 199 !- 200 CALL get_findkey (1,targetname,pos) 198 201 !- 199 202 size_of_in = SIZE(ret_val) … … 209 212 IF (pos < 0) THEN 210 213 !-- Get the information out of the file 211 CALL get_fil (target ,status,fileorig,i_val=tmp_ret_val)214 CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val) 212 215 !-- Put the data into the database 213 216 CALL get_wdb & 214 & (target ,status,fileorig,size_of_in,i_val=tmp_ret_val)217 & (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val) 215 218 ELSE 216 219 !-- Get the value out of the database 217 CALL get_rdb (pos,size_of_in,target ,i_val=tmp_ret_val)220 CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val) 218 221 ENDIF 219 222 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) … … 221 224 END SUBROUTINE getini1d 222 225 !=== 223 SUBROUTINE getini2d (target ,ret_val)224 !--------------------------------------------------------------------- 225 IMPLICIT NONE 226 !- 227 CHARACTER(LEN=*) :: target 226 SUBROUTINE getini2d (targetname,ret_val) 227 !--------------------------------------------------------------------- 228 IMPLICIT NONE 229 !- 230 CHARACTER(LEN=*) :: targetname 228 231 INTEGER,DIMENSION(:,:) :: ret_val 229 232 !- … … 234 237 !--------------------------------------------------------------------- 235 238 !- 236 ! Do we have this target in our database ?237 !- 238 CALL get_findkey (1,target ,pos)239 ! Do we have this targetname in our database ? 240 !- 241 CALL get_findkey (1,targetname,pos) 239 242 !- 240 243 size_of_in = SIZE(ret_val) … … 259 262 IF (pos < 0) THEN 260 263 !-- Get the information out of the file 261 CALL get_fil (target ,status,fileorig,i_val=tmp_ret_val)264 CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val) 262 265 !-- Put the data into the database 263 266 CALL get_wdb & 264 & (target ,status,fileorig,size_of_in,i_val=tmp_ret_val)267 & (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val) 265 268 ELSE 266 269 !-- Get the value out of the database 267 CALL get_rdb (pos,size_of_in,target ,i_val=tmp_ret_val)270 CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val) 268 271 ENDIF 269 272 !- … … 280 283 !=== REAL INTERFACE 281 284 !- 282 SUBROUTINE getinrs (target ,ret_val)283 !--------------------------------------------------------------------- 284 IMPLICIT NONE 285 !- 286 CHARACTER(LEN=*) :: target 285 SUBROUTINE getinrs (targetname,ret_val) 286 !--------------------------------------------------------------------- 287 IMPLICIT NONE 288 !- 289 CHARACTER(LEN=*) :: targetname 287 290 REAL :: ret_val 288 291 !- 289 292 REAL,DIMENSION(1) :: tmp_ret_val 290 INTEGER :: pos,status=0,fileorig 291 !--------------------------------------------------------------------- 292 !- 293 ! Do we have this target in our database ?294 !- 295 CALL get_findkey (1,target ,pos)293 INTEGER :: pos,status=0,fileorig, size_of_in 294 !--------------------------------------------------------------------- 295 !- 296 ! Do we have this targetname in our database ? 297 !- 298 CALL get_findkey (1,targetname,pos) 296 299 !- 297 300 tmp_ret_val(1) = ret_val 301 size_of_in = SIZE(tmp_ret_val) 298 302 !- 299 303 IF (pos < 0) THEN 300 304 !-- Get the information out of the file 301 CALL get_fil (target ,status,fileorig,r_val=tmp_ret_val)305 CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val) 302 306 !-- Put the data into the database 303 307 CALL get_wdb & 304 & (target ,status,fileorig,1,r_val=tmp_ret_val)308 & (targetname,status,fileorig,1,r_val=tmp_ret_val) 305 309 ELSE 306 310 !-- Get the value out of the database 307 CALL get_rdb (pos,1,target ,r_val=tmp_ret_val)311 CALL get_rdb (pos,1,targetname,r_val=tmp_ret_val) 308 312 ENDIF 309 313 ret_val = tmp_ret_val(1) … … 311 315 END SUBROUTINE getinrs 312 316 !=== 313 SUBROUTINE getinr1d (target ,ret_val)314 !--------------------------------------------------------------------- 315 IMPLICIT NONE 316 !- 317 CHARACTER(LEN=*) :: target 317 SUBROUTINE getinr1d (targetname,ret_val) 318 !--------------------------------------------------------------------- 319 IMPLICIT NONE 320 !- 321 CHARACTER(LEN=*) :: targetname 318 322 REAL,DIMENSION(:) :: ret_val 319 323 !- … … 323 327 !--------------------------------------------------------------------- 324 328 !- 325 ! Do we have this target in our database ?326 !- 327 CALL get_findkey (1,target ,pos)329 ! Do we have this targetname in our database ? 330 !- 331 CALL get_findkey (1,targetname,pos) 328 332 !- 329 333 size_of_in = SIZE(ret_val) … … 339 343 IF (pos < 0) THEN 340 344 !-- Get the information out of the file 341 CALL get_fil (target ,status,fileorig,r_val=tmp_ret_val)345 CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val) 342 346 !-- Put the data into the database 343 347 CALL get_wdb & 344 & (target ,status,fileorig,size_of_in,r_val=tmp_ret_val)348 & (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val) 345 349 ELSE 346 350 !-- Get the value out of the database 347 CALL get_rdb (pos,size_of_in,target ,r_val=tmp_ret_val)351 CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val) 348 352 ENDIF 349 353 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) … … 351 355 END SUBROUTINE getinr1d 352 356 !=== 353 SUBROUTINE getinr2d (target ,ret_val)354 !--------------------------------------------------------------------- 355 IMPLICIT NONE 356 !- 357 CHARACTER(LEN=*) :: target 357 SUBROUTINE getinr2d (targetname,ret_val) 358 !--------------------------------------------------------------------- 359 IMPLICIT NONE 360 !- 361 CHARACTER(LEN=*) :: targetname 358 362 REAL,DIMENSION(:,:) :: ret_val 359 363 !- … … 364 368 !--------------------------------------------------------------------- 365 369 !- 366 ! Do we have this target in our database ?367 !- 368 CALL get_findkey (1,target ,pos)370 ! Do we have this targetname in our database ? 371 !- 372 CALL get_findkey (1,targetname,pos) 369 373 !- 370 374 size_of_in = SIZE(ret_val) … … 389 393 IF (pos < 0) THEN 390 394 !-- Get the information out of the file 391 CALL get_fil (target ,status,fileorig,r_val=tmp_ret_val)395 CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val) 392 396 !-- Put the data into the database 393 397 CALL get_wdb & 394 & (target ,status,fileorig,size_of_in,r_val=tmp_ret_val)398 & (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val) 395 399 ELSE 396 400 !-- Get the value out of the database 397 CALL get_rdb (pos,size_of_in,target ,r_val=tmp_ret_val)401 CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val) 398 402 ENDIF 399 403 !- … … 410 414 !=== CHARACTER INTERFACE 411 415 !- 412 SUBROUTINE getincs (target ,ret_val)413 !--------------------------------------------------------------------- 414 IMPLICIT NONE 415 !- 416 CHARACTER(LEN=*) :: target 416 SUBROUTINE getincs (targetname,ret_val) 417 !--------------------------------------------------------------------- 418 IMPLICIT NONE 419 !- 420 CHARACTER(LEN=*) :: targetname 417 421 CHARACTER(LEN=*) :: ret_val 418 422 !- 419 423 CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val 420 INTEGER :: pos,status=0,fileorig 421 !--------------------------------------------------------------------- 422 !- 423 ! Do we have this target in our database ?424 !- 425 CALL get_findkey (1,target ,pos)424 INTEGER :: pos,status=0,fileorig,size_of_in 425 !--------------------------------------------------------------------- 426 !- 427 ! Do we have this targetname in our database ? 428 !- 429 CALL get_findkey (1,targetname,pos) 426 430 !- 427 431 tmp_ret_val(1) = ret_val 432 size_of_in = SIZE(tmp_ret_val) 428 433 !- 429 434 IF (pos < 0) THEN 430 435 !-- Get the information out of the file 431 CALL get_fil (target ,status,fileorig,c_val=tmp_ret_val)436 CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val) 432 437 !-- Put the data into the database 433 438 CALL get_wdb & 434 & (target ,status,fileorig,1,c_val=tmp_ret_val)439 & (targetname,status,fileorig,1,c_val=tmp_ret_val) 435 440 ELSE 436 441 !-- Get the value out of the database 437 CALL get_rdb (pos,1,target ,c_val=tmp_ret_val)442 CALL get_rdb (pos,1,targetname,c_val=tmp_ret_val) 438 443 ENDIF 439 444 ret_val = tmp_ret_val(1) … … 441 446 END SUBROUTINE getincs 442 447 !=== 443 SUBROUTINE getinc1d (target ,ret_val)444 !--------------------------------------------------------------------- 445 IMPLICIT NONE 446 !- 447 CHARACTER(LEN=*) :: target 448 SUBROUTINE getinc1d (targetname,ret_val) 449 !--------------------------------------------------------------------- 450 IMPLICIT NONE 451 !- 452 CHARACTER(LEN=*) :: targetname 448 453 CHARACTER(LEN=*),DIMENSION(:) :: ret_val 449 454 !- … … 453 458 !--------------------------------------------------------------------- 454 459 !- 455 ! Do we have this target in our database ?456 !- 457 CALL get_findkey (1,target ,pos)460 ! Do we have this targetname in our database ? 461 !- 462 CALL get_findkey (1,targetname,pos) 458 463 !- 459 464 size_of_in = SIZE(ret_val) … … 469 474 IF (pos < 0) THEN 470 475 !-- Get the information out of the file 471 CALL get_fil (target ,status,fileorig,c_val=tmp_ret_val)476 CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val) 472 477 !-- Put the data into the database 473 478 CALL get_wdb & 474 & (target ,status,fileorig,size_of_in,c_val=tmp_ret_val)479 & (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val) 475 480 ELSE 476 481 !-- Get the value out of the database 477 CALL get_rdb (pos,size_of_in,target ,c_val=tmp_ret_val)482 CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val) 478 483 ENDIF 479 484 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) … … 481 486 END SUBROUTINE getinc1d 482 487 !=== 483 SUBROUTINE getinc2d (target ,ret_val)484 !--------------------------------------------------------------------- 485 IMPLICIT NONE 486 !- 487 CHARACTER(LEN=*) :: target 488 SUBROUTINE getinc2d (targetname,ret_val) 489 !--------------------------------------------------------------------- 490 IMPLICIT NONE 491 !- 492 CHARACTER(LEN=*) :: targetname 488 493 CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val 489 494 !- … … 494 499 !--------------------------------------------------------------------- 495 500 !- 496 ! Do we have this target in our database ?497 !- 498 CALL get_findkey (1,target ,pos)501 ! Do we have this targetname in our database ? 502 !- 503 CALL get_findkey (1,targetname,pos) 499 504 !- 500 505 size_of_in = SIZE(ret_val) … … 519 524 IF (pos < 0) THEN 520 525 !-- Get the information out of the file 521 CALL get_fil (target ,status,fileorig,c_val=tmp_ret_val)526 CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val) 522 527 !-- Put the data into the database 523 528 CALL get_wdb & 524 & (target ,status,fileorig,size_of_in,c_val=tmp_ret_val)529 & (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val) 525 530 ELSE 526 531 !-- Get the value out of the database 527 CALL get_rdb (pos,size_of_in,target ,c_val=tmp_ret_val)532 CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val) 528 533 ENDIF 529 534 !- … … 540 545 !=== LOGICAL INTERFACE 541 546 !- 542 SUBROUTINE getinls (target ,ret_val)543 !--------------------------------------------------------------------- 544 IMPLICIT NONE 545 !- 546 CHARACTER(LEN=*) :: target 547 SUBROUTINE getinls (targetname,ret_val) 548 !--------------------------------------------------------------------- 549 IMPLICIT NONE 550 !- 551 CHARACTER(LEN=*) :: targetname 547 552 LOGICAL :: ret_val 548 553 !- 549 554 LOGICAL,DIMENSION(1) :: tmp_ret_val 550 INTEGER :: pos,status=0,fileorig 551 !--------------------------------------------------------------------- 552 !- 553 ! Do we have this target in our database ?554 !- 555 CALL get_findkey (1,target ,pos)555 INTEGER :: pos,status=0,fileorig,size_of_in 556 !--------------------------------------------------------------------- 557 !- 558 ! Do we have this targetname in our database ? 559 !- 560 CALL get_findkey (1,targetname,pos) 556 561 !- 557 562 tmp_ret_val(1) = ret_val 563 size_of_in = SIZE(tmp_ret_val) 558 564 !- 559 565 IF (pos < 0) THEN 560 566 !-- Get the information out of the file 561 CALL get_fil (target ,status,fileorig,l_val=tmp_ret_val)567 CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val) 562 568 !-- Put the data into the database 563 569 CALL get_wdb & 564 & (target ,status,fileorig,1,l_val=tmp_ret_val)570 & (targetname,status,fileorig,1,l_val=tmp_ret_val) 565 571 ELSE 566 572 !-- Get the value out of the database 567 CALL get_rdb (pos,1,target ,l_val=tmp_ret_val)573 CALL get_rdb (pos,1,targetname,l_val=tmp_ret_val) 568 574 ENDIF 569 575 ret_val = tmp_ret_val(1) … … 571 577 END SUBROUTINE getinls 572 578 !=== 573 SUBROUTINE getinl1d (target ,ret_val)574 !--------------------------------------------------------------------- 575 IMPLICIT NONE 576 !- 577 CHARACTER(LEN=*) :: target 579 SUBROUTINE getinl1d (targetname,ret_val) 580 !--------------------------------------------------------------------- 581 IMPLICIT NONE 582 !- 583 CHARACTER(LEN=*) :: targetname 578 584 LOGICAL,DIMENSION(:) :: ret_val 579 585 !- … … 583 589 !--------------------------------------------------------------------- 584 590 !- 585 ! Do we have this target in our database ?586 !- 587 CALL get_findkey (1,target ,pos)591 ! Do we have this targetname in our database ? 592 !- 593 CALL get_findkey (1,targetname,pos) 588 594 !- 589 595 size_of_in = SIZE(ret_val) … … 599 605 IF (pos < 0) THEN 600 606 !-- Get the information out of the file 601 CALL get_fil (target ,status,fileorig,l_val=tmp_ret_val)607 CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val) 602 608 !-- Put the data into the database 603 609 CALL get_wdb & 604 & (target ,status,fileorig,size_of_in,l_val=tmp_ret_val)610 & (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val) 605 611 ELSE 606 612 !-- Get the value out of the database 607 CALL get_rdb (pos,size_of_in,target ,l_val=tmp_ret_val)613 CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val) 608 614 ENDIF 609 615 ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) … … 611 617 END SUBROUTINE getinl1d 612 618 !=== 613 SUBROUTINE getinl2d (target ,ret_val)614 !--------------------------------------------------------------------- 615 IMPLICIT NONE 616 !- 617 CHARACTER(LEN=*) :: target 619 SUBROUTINE getinl2d (targetname,ret_val) 620 !--------------------------------------------------------------------- 621 IMPLICIT NONE 622 !- 623 CHARACTER(LEN=*) :: targetname 618 624 LOGICAL,DIMENSION(:,:) :: ret_val 619 625 !- … … 624 630 !--------------------------------------------------------------------- 625 631 !- 626 ! Do we have this target in our database ?627 !- 628 CALL get_findkey (1,target ,pos)632 ! Do we have this targetname in our database ? 633 !- 634 CALL get_findkey (1,targetname,pos) 629 635 !- 630 636 size_of_in = SIZE(ret_val) … … 649 655 IF (pos < 0) THEN 650 656 !-- Get the information out of the file 651 CALL get_fil (target ,status,fileorig,l_val=tmp_ret_val)657 CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val) 652 658 !-- Put the data into the database 653 659 CALL get_wdb & 654 & (target ,status,fileorig,size_of_in,l_val=tmp_ret_val)660 & (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val) 655 661 ELSE 656 662 !-- Get the value out of the database 657 CALL get_rdb (pos,size_of_in,target ,l_val=tmp_ret_val)663 CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val) 658 664 ENDIF 659 665 !- … … 670 676 !=== Generic file/database INTERFACE 671 677 !- 672 SUBROUTINE get_fil (target ,status,fileorig,i_val,r_val,c_val,l_val)678 SUBROUTINE get_fil (targetname,status,fileorig,nb_to_ret,i_val,r_val,c_val,l_val) 673 679 !--------------------------------------------------------------------- 674 680 !- Subroutine that will extract from the file the values 675 !- attributed to the keyword target 676 !- 677 !- (C) target : target for which we will look in the file681 !- attributed to the keyword targetname 682 !- 683 !- (C) targetname : target for which we will look in the file 678 684 !- (I) status : tells us from where we obtained the data 679 685 !- (I) fileorig : index of the file from which the key comes 686 !- (I) nb_to_ret : size of output vector 680 687 !- (I) i_val(:) : INTEGER(nb_to_ret) values 681 688 !- (R) r_val(:) : REAL(nb_to_ret) values … … 685 692 IMPLICIT NONE 686 693 !- 687 CHARACTER(LEN=*) :: target 688 INTEGER,INTENT(OUT) :: status,fileorig 694 CHARACTER(LEN=*) :: targetname 695 INTEGER,INTENT(OUT) :: status,fileorig,nb_to_ret 689 696 INTEGER,DIMENSION(:),OPTIONAL :: i_val 690 697 REAL,DIMENSION(:),OPTIONAL :: r_val … … 692 699 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val 693 700 !- 694 INTEGER :: k_typ, nb_to_ret,it,pos,len_str,status_cnt,io_err701 INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err 695 702 CHARACTER(LEN=n_d_fmt) :: cnt 696 703 CHARACTER(LEN=80) :: str_READ,str_READ_lower … … 702 709 REAL :: r_cmpval 703 710 INTEGER :: ipos_tr,ipos_fl 711 LOGICAL :: l_dbg 712 !--------------------------------------------------------------------- 713 CALL ipsldbg (old_status=l_dbg) 704 714 !--------------------------------------------------------------------- 705 715 !- 706 716 ! Get the type of the argument 707 717 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 708 SELECT CASE (k_typ) 709 CASE(k_i) 710 nb_to_ret = SIZE(i_val) 711 CASE(k_r) 712 nb_to_ret = SIZE(r_val) 713 CASE(k_c) 714 nb_to_ret = SIZE(c_val) 715 CASE(k_l) 716 nb_to_ret = SIZE(l_val) 717 CASE DEFAULT 718 IF ( (k_typ.NE.k_i) .AND. (k_typ.NE.k_r) .AND. (k_typ.NE.k_c) .AND. (k_typ.NE.k_l) ) THEN 718 719 CALL ipslerr (3,'get_fil', & 719 720 & 'Internal error','Unknown type of data',' ') 720 END SELECT721 ENDIF 721 722 !- 722 723 ! Read the file(s) … … 731 732 !--- 732 733 !-- First try the target as it is 733 CALL get_findkey (2,target ,pos)734 CALL get_findkey (2,targetname,pos) 734 735 !--- 735 736 !-- Another try … … 737 738 IF (pos < 0) THEN 738 739 WRITE(UNIT=cnt,FMT=c_i_fmt) it 739 CALL get_findkey (2,TRIM(target )//'__'//cnt,pos)740 CALL get_findkey (2,TRIM(targetname)//'__'//cnt,pos) 740 741 ENDIF 741 742 !--- … … 748 749 found(it) = .TRUE. 749 750 fileorig = fromfile(pos) 751 ! 752 IF (l_dbg) THEN 753 WRITE(*,*) & 754 & 'getin_fil : read key ',targetname,' from file ',fileorig,' has type ',k_typ 755 ENDIF 750 756 !----- 751 757 !---- DECODE … … 754 760 str_READ_lower = str_READ 755 761 CALL strlowercase (str_READ_lower) 762 IF (l_dbg) THEN 763 WRITE(*,*) & 764 & ' value ',str_READ_lower 765 ENDIF 756 766 !----- 757 767 IF ( (TRIM(str_READ_lower) == 'def') & … … 789 799 IF (io_err /= 0) THEN 790 800 CALL ipslerr (3,'get_fil', & 791 & 'Target '//TRIM(target ), &801 & 'Target '//TRIM(targetname), & 792 802 & 'is not of '//TRIM(c_vtyp)//' type',' ') 793 803 ENDIF … … 801 811 IF (compline(pos) /= nb_to_ret) THEN 802 812 CALL ipslerr (2,'get_fil', & 803 & 'For key '//TRIM(target )//' we have a compressed field', &813 & 'For key '//TRIM(targetname)//' we have a compressed field', & 804 814 & 'which does not have the right size.', & 805 815 & 'We will try to fix that.') … … 837 847 ! Now we set the status for what we found 838 848 IF (def_beha) THEN 839 status = 2 840 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) 849 status = default 850 CALL ipslerr (1,'USING DEFAULT BEHAVIOUR FOR', & 851 & TRIM(targetname),' ',' ') 852 WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(targetname) 841 853 ELSE 842 854 status_cnt = 0 … … 846 858 IF (status_cnt <= max_msgs) THEN 847 859 WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & 848 & ADVANCE='NO') TRIM(target )860 & ADVANCE='NO') TRIM(targetname) 849 861 IF (nb_to_ret > 1) THEN 850 862 WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') … … 868 880 !--- 869 881 IF (status_cnt == 0) THEN 870 status = 1882 status = nondefault 871 883 ELSE IF (status_cnt == nb_to_ret) THEN 872 status = 2884 status = default 873 885 ELSE 874 status = 3886 status = vectornondefault 875 887 ENDIF 876 888 ENDIF … … 880 892 END SUBROUTINE get_fil 881 893 !=== 882 SUBROUTINE get_rdb (pos,size_of_in,target ,i_val,r_val,c_val,l_val)894 SUBROUTINE get_rdb (pos,size_of_in,targetname,i_val,r_val,c_val,l_val) 883 895 !--------------------------------------------------------------------- 884 896 !- Read the required variable in the database … … 887 899 !- 888 900 INTEGER :: pos,size_of_in 889 CHARACTER(LEN=*) :: target 901 CHARACTER(LEN=*) :: targetname 890 902 INTEGER,DIMENSION(:),OPTIONAL :: i_val 891 903 REAL,DIMENSION(:),OPTIONAL :: r_val … … 907 919 IF (key_tab(pos)%keytype /= k_typ) THEN 908 920 CALL ipslerr (3,'get_rdb', & 909 & 'Wrong data type for keyword '//TRIM(target ), &921 & 'Wrong data type for keyword '//TRIM(targetname), & 910 922 & '(NOT '//TRIM(c_vtyp)//')',' ') 911 923 ENDIF … … 915 927 & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN 916 928 CALL ipslerr (3,'get_rdb', & 917 & 'Wrong compression length','for keyword '//TRIM(target ),' ')929 & 'Wrong compression length','for keyword '//TRIM(targetname),' ') 918 930 ELSE 919 931 SELECT CASE (k_typ) … … 927 939 IF (key_tab(pos)%keymemlen /= size_of_in) THEN 928 940 CALL ipslerr (3,'get_rdb', & 929 & 'Wrong array length','for keyword '//TRIM(target ),' ')941 & 'Wrong array length','for keyword '//TRIM(targetname),' ') 930 942 ELSE 931 943 k_beg = key_tab(pos)%keymemstart … … 947 959 !=== 948 960 SUBROUTINE get_wdb & 949 & (target ,status,fileorig,size_of_in, &961 & (targetname,status,fileorig,size_of_in, & 950 962 & i_val,r_val,c_val,l_val) 951 963 !--------------------------------------------------------------------- … … 954 966 IMPLICIT NONE 955 967 !- 956 CHARACTER(LEN=*) :: target 968 CHARACTER(LEN=*) :: targetname 957 969 INTEGER :: status,fileorig,size_of_in 958 970 INTEGER,DIMENSION(:),OPTIONAL :: i_val … … 965 977 INTEGER :: k_mempos,k_memsize,k_beg,k_end 966 978 LOGICAL :: l_cmp 979 LOGICAL :: l_dbg 980 !--------------------------------------------------------------------- 981 CALL ipsldbg (old_status=l_dbg) 967 982 !--------------------------------------------------------------------- 968 983 !- … … 999 1014 ! Fill out the items of the data base 1000 1015 nb_keys = nb_keys+1 1001 key_tab(nb_keys)%keystr = target (1:MIN(LEN_TRIM(target),l_n))1016 key_tab(nb_keys)%keystr = targetname(1:MIN(LEN_TRIM(targetname),l_n)) 1002 1017 key_tab(nb_keys)%keystatus = status 1003 1018 key_tab(nb_keys)%keytype = k_typ … … 1011 1026 key_tab(nb_keys)%keymemlen = size_of_in 1012 1027 ENDIF 1028 IF (l_dbg) THEN 1029 WRITE(*,*) & 1030 & "get_wdb : nb_keys ",nb_keys," key_tab keystr ",key_tab(nb_keys)%keystr,& 1031 & ",keystatus ",key_tab(nb_keys)%keystatus,& 1032 & ",keytype ",key_tab(nb_keys)%keytype,& 1033 & ",keycompress ",key_tab(nb_keys)%keycompress,& 1034 & ",keyfromfile ",key_tab(nb_keys)%keyfromfile,& 1035 & ",keymemstart ",key_tab(nb_keys)%keymemstart 1036 ENDIF 1037 1013 1038 !- 1014 1039 ! Before writing the actual size lets see if we have the space … … 1086 1111 !- 1087 1112 INTEGER :: eof,ptn,len_str,i,it,iund,io_err 1088 LOGICAL :: check = .FALSE. 1113 LOGICAL :: l_dbg 1114 !--------------------------------------------------------------------- 1115 CALL ipsldbg (old_status=l_dbg) 1089 1116 !--------------------------------------------------------------------- 1090 1117 eof = 0 … … 1092 1119 nb_lastkey = 0 1093 1120 !- 1094 IF ( check) THEN1121 IF (l_dbg) THEN 1095 1122 WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) 1096 1123 ENDIF … … 1133 1160 CALL cmpblank (NEW_str) 1134 1161 NEW_str = TRIM(ADJUSTL(NEW_str)) 1135 IF ( check) THEN1162 IF (l_dbg) THEN 1136 1163 WRITE(*,*) & 1137 1164 & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) … … 1171 1198 !---- If we have an empty line then the keyword finishes 1172 1199 nb_lastkey = 0 1173 IF ( check) THEN1200 IF (l_dbg) THEN 1174 1201 WRITE(*,*) 'getin_readdef : Have found an emtpy line ' 1175 1202 ENDIF … … 1179 1206 CLOSE(UNIT=22) 1180 1207 !- 1181 IF ( check) THEN1208 IF (l_dbg) THEN 1182 1209 OPEN (UNIT=22,file=TRIM(def_file)//'.test') 1183 1210 DO i=1,nb_lines … … 1186 1213 CLOSE(UNIT=22) 1187 1214 ENDIF 1215 !- 1216 IF (l_dbg) THEN 1217 WRITE(*,*) "nb_lines ",nb_lines,"nb_keys ",nb_keys 1218 WRITE(*,*) "fichier ",fichier(1:nb_lines) 1219 WRITE(*,*) "targetlist ",targetlist(1:nb_lines) 1220 WRITE(*,*) "fromfile ",fromfile(1:nb_lines) 1221 WRITE(*,*) "compline ",compline(1:nb_lines) 1222 WRITE(*,*) '<-getin_readdef' 1223 ENDIF 1188 1224 !--------------------------- 1189 1225 END SUBROUTINE getin_readdef … … 1210 1246 CHARACTER(LEN=n_d_fmt) :: cnt 1211 1247 CHARACTER(LEN=10) :: c_fmt 1248 LOGICAL :: l_dbg 1249 !--------------------------------------------------------------------- 1250 CALL ipsldbg (old_status=l_dbg) 1212 1251 !--------------------------------------------------------------------- 1213 1252 len_str = LEN_TRIM(NEW_str) … … 1365 1404 !- 1366 1405 ENDIF 1406 1407 IF (l_dbg) THEN 1408 WRITE(*,*) "getin_decrypt ->",TRIM(NEW_str), " : ", & 1409 & TRIM(fichier(nb_lines)), & 1410 & fromfile(nb_lines), & 1411 & TRIM(filelist(fromfile(nb_lines))) 1412 WRITE(*,*) " compline : ",compline(nb_lines) 1413 WRITE(*,*) " targetlist : ",TRIM(targetlist(nb_lines)) 1414 WRITE(*,*) " last_key : ",last_key 1415 ENDIF 1367 1416 !--------------------------- 1368 1417 END SUBROUTINE getin_decrypt … … 1402 1451 WRITE(*,*) & 1403 1452 & 'getin_checkcohe : We will keep only the last value' 1453 CALL ipslerr (2,'getin_checkcohe','Found a problem on key ', & 1454 & TRIM(targetlist(line)), fichier(line)//" "//fichier(k)) 1404 1455 targetlist(line) = ' ' 1405 1456 ENDIF … … 1778 1829 CHARACTER(LEN=80) :: usedfileprefix 1779 1830 INTEGER :: ikey,if,iff,iv 1831 INTEGER :: ios 1780 1832 CHARACTER(LEN=20) :: c_tmp 1781 1833 CHARACTER(LEN=100) :: tmp_str,used_filename 1782 LOGICAL :: check = .FALSE. 1834 INTEGER :: io_err 1835 LOGICAL :: l_dbg 1836 !--------------------------------------------------------------------- 1837 CALL ipsldbg (old_status=l_dbg) 1783 1838 !--------------------------------------------------------------------- 1784 1839 IF (PRESENT(fileprefix)) THEN … … 1791 1846 !--- 1792 1847 used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) 1793 IF ( check) THEN1848 IF (l_dbg) THEN 1794 1849 WRITE(*,*) & 1795 & ' GETIN_DUMP: opens file : ',TRIM(used_filename),' if = ',if1850 & 'getin_dump : opens file : ',TRIM(used_filename),' if = ',if 1796 1851 WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys 1797 1852 ENDIF 1798 OPEN (UNIT=22,FILE=used_filename) 1853 OPEN (UNIT=22,FILE=used_filename,iostat=io_err) 1854 IF (io_err /= 0) THEN 1855 CALL ipslerr (3,'getin_dump', & 1856 & 'Could not open file :',TRIM(used_filename), & 1857 & '') 1858 ENDIF 1799 1859 !--- 1800 1860 !-- If this is the first file we need to add the list … … 1808 1868 ENDDO 1809 1869 WRITE(22,*) '# ' 1870 IF (l_dbg) THEN 1871 WRITE(*,*) '# ' 1872 WRITE(*,*) '# This file is linked to the following files :' 1873 WRITE(*,*) '# ' 1874 DO iff=2,nbfiles 1875 WRITE(*,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) 1876 ENDDO 1877 WRITE(*,*) '# ' 1878 ENDIF 1810 1879 ENDIF 1811 1880 !--- … … 1818 1887 WRITE(22,*) '#' 1819 1888 SELECT CASE (key_tab(ikey)%keystatus) 1820 CASE( 1)1889 CASE(nondefault) 1821 1890 WRITE(22,*) '# Values of ', & 1822 1891 & TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file) 1823 CASE( 2)1892 CASE(default) 1824 1893 WRITE(22,*) '# Values of ', & 1825 1894 & TRIM(key_tab(ikey)%keystr),' are all defaults.' 1826 CASE( 3)1895 CASE(vectornondefault) 1827 1896 WRITE(22,*) '# Values of ', & 1828 1897 & TRIM(key_tab(ikey)%keystr), & … … 1833 1902 END SELECT 1834 1903 WRITE(22,*) '#' 1904 !- 1905 IF (l_dbg) THEN 1906 WRITE(*,*) '#' 1907 WRITE(*,*) '# Status of key ', ikey, ' : ',& 1908 & TRIM(key_tab(ikey)%keystr),key_tab(ikey)%keystatus 1909 ENDIF 1835 1910 !------- 1836 1911 !------ Write the values
Note: See TracChangeset
for help on using the changeset viewer.