Changeset 125 for IOIPSL/trunk/src
- Timestamp:
- 08/08/07 15:15:02 (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
IOIPSL/trunk/src/getincom.f90
r11 r125 5 5 USE errioipsl, ONLY : ipslerr 6 6 USE stringop, & 7 & ONLY : nocomma,cmpblank,strlowercase ,gensig,find_sig7 & ONLY : nocomma,cmpblank,strlowercase 8 8 !- 9 9 IMPLICIT NONE … … 13 13 !- 14 14 INTERFACE getin 15 !!-------------------------------------------------------------------- 16 !! The "getin" routines get a variable. 17 !! We first check if we find it in the database 18 !! and if not we get it from the run.def file. 19 !! 20 !! SUBROUTINE getin (target,ret_val) 21 !! 22 !! INPUT 23 !! 24 !! (C) target : Name of the variable 25 !! 26 !! OUTPUT 27 !! 28 !! (I/R/C/L) ret_val : scalar, vector or matrix that will contain 29 !! that will contain the (standard) 30 !! integer/real/character/logical values 31 !!-------------------------------------------------------------------- 15 32 MODULE PROCEDURE getinrs, getinr1d, getinr2d, & 16 33 & getinis, getini1d, getini2d, & … … 19 36 END INTERFACE 20 37 !- 38 !!-------------------------------------------------------------------- 39 !! The "getin_dump" routine will dump the content of the database 40 !! into a file which has the same format as the run.def file. 41 !! The idea is that the user can see which parameters were used 42 !! and re-use the file for another run. 43 !! 44 !! SUBROUTINE getin_dump (fileprefix) 45 !! 46 !! OPTIONAL INPUT argument 47 !! 48 !! (C) fileprefix : allows the user to change the name of the file 49 !! in which the data will be archived 50 !!-------------------------------------------------------------------- 51 !- 21 52 INTEGER,PARAMETER :: max_files=100 22 53 CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist … … 26 57 INTEGER,SAVE :: nb_lines 27 58 CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier 28 INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline29 CHARACTER(LEN=l_n),DIMENSION(max_lines),SAVE 59 INTEGER,DIMENSION(max_lines),SAVE :: fromfile,compline 60 CHARACTER(LEN=l_n),DIMENSION(max_lines),SAVE :: targetlist 30 61 !- 31 62 INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 … … 39 70 INTEGER,SAVE :: nb_keys=0 40 71 INTEGER,SAVE :: keymemsize=0 41 INTEGER,SAVE,ALLOCATABLE :: keysig(:) 42 CHARACTER(LEN=l_n),SAVE,ALLOCATABLE :: keystr(:) 72 !- 73 ! keystr definition 74 ! name of a key 43 75 !- 44 76 ! keystatus definition … … 46 78 ! keystatus = 2 : Default value is used 47 79 ! keystatus = 3 : Some vector elements were taken from default 48 !-49 INTEGER,SAVE,ALLOCATABLE :: keystatus(:)50 80 !- 51 81 ! keytype definition … … 57 87 INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 58 88 !- 59 INTEGER,SAVE,ALLOCATABLE :: keytype(:)60 !-61 89 ! Allow compression for keys (only for integer and real) 62 ! keycompress < 0 : not compresse s90 ! keycompress < 0 : not compressed 63 91 ! keycompress > 0 : number of repeat of the value 64 92 !- 65 INTEGER,SAVE,ALLOCATABLE :: keycompress(:) 66 INTEGER,SAVE,ALLOCATABLE :: keyfromfile(:) 67 !- 68 INTEGER,SAVE,ALLOCATABLE :: keymemstart(:) 69 INTEGER,SAVE,ALLOCATABLE :: keymemlen(:) 93 TYPE :: t_key 94 CHARACTER(LEN=l_n) :: keystr 95 INTEGER :: keystatus, keytype, keycompress, & 96 & keyfromfile, keymemstart, keymemlen 97 END TYPE t_key 98 !- 99 TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab 70 100 !- 71 101 INTEGER,SAVE,ALLOCATABLE :: i_mem(:) … … 84 114 SUBROUTINE getinis (target,ret_val) 85 115 !--------------------------------------------------------------------- 86 !- Get a interer scalar. We first check if we find it87 !- in the database and if not we get it from the run.def88 !-89 !- getini1d and getini2d are written on the same pattern90 !---------------------------------------------------------------------91 116 IMPLICIT NONE 92 117 !- … … 95 120 !- 96 121 INTEGER,DIMENSION(1) :: tmp_ret_val 97 INTEGER :: target_sig,pos,status=0,fileorig 98 !--------------------------------------------------------------------- 99 !- 100 ! Compute the signature of the target 101 !- 102 CALL gensig (target,target_sig) 122 INTEGER :: pos,status=0,fileorig 123 !--------------------------------------------------------------------- 103 124 !- 104 125 ! Do we have this target in our database ? 105 126 !- 106 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)127 CALL get_findkey (1,target,pos) 107 128 !- 108 129 tmp_ret_val(1) = ret_val … … 113 134 !-- Put the data into the database 114 135 CALL get_wdb & 115 & (target, target_sig,status,fileorig,1,i_val=tmp_ret_val)136 & (target,status,fileorig,1,i_val=tmp_ret_val) 116 137 ELSE 117 138 !-- Get the value out of the database … … 124 145 SUBROUTINE getini1d (target,ret_val) 125 146 !--------------------------------------------------------------------- 126 !- See getinis for details. It is the same thing but for a vector127 !---------------------------------------------------------------------128 147 IMPLICIT NONE 129 148 !- … … 133 152 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 134 153 INTEGER,SAVE :: tmp_ret_size = 0 135 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 136 !--------------------------------------------------------------------- 137 !- 138 ! Compute the signature of the target 139 !- 140 CALL gensig (target,target_sig) 154 INTEGER :: pos,size_of_in,status=0,fileorig 155 !--------------------------------------------------------------------- 141 156 !- 142 157 ! Do we have this target in our database ? 143 158 !- 144 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)159 CALL get_findkey (1,target,pos) 145 160 !- 146 161 size_of_in = SIZE(ret_val) … … 159 174 !-- Put the data into the database 160 175 CALL get_wdb & 161 & (target, target_sig,status,fileorig,size_of_in,i_val=tmp_ret_val)176 & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) 162 177 ELSE 163 178 !-- Get the value out of the database … … 170 185 SUBROUTINE getini2d (target,ret_val) 171 186 !--------------------------------------------------------------------- 172 !- See getinis for details. It is the same thing but for a matrix173 !---------------------------------------------------------------------174 187 IMPLICIT NONE 175 188 !- … … 179 192 INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 180 193 INTEGER,SAVE :: tmp_ret_size = 0 181 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig194 INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig 182 195 INTEGER :: jl,jj,ji 183 196 !--------------------------------------------------------------------- 184 197 !- 185 ! Compute the signature of the target186 !-187 CALL gensig (target,target_sig)188 !-189 198 ! Do we have this target in our database ? 190 199 !- 191 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)200 CALL get_findkey (1,target,pos) 192 201 !- 193 202 size_of_in = SIZE(ret_val) … … 215 224 !-- Put the data into the database 216 225 CALL get_wdb & 217 & (target, target_sig,status,fileorig,size_of_in,i_val=tmp_ret_val)226 & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) 218 227 ELSE 219 228 !-- Get the value out of the database … … 235 244 SUBROUTINE getinrs (target,ret_val) 236 245 !--------------------------------------------------------------------- 237 !- Get a real scalar. We first check if we find it238 !- in the database and if not we get it from the run.def239 !-240 !- getinr1d and getinr2d are written on the same pattern241 !---------------------------------------------------------------------242 246 IMPLICIT NONE 243 247 !- … … 246 250 !- 247 251 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) 252 INTEGER :: pos,status=0,fileorig 253 !--------------------------------------------------------------------- 254 254 !- 255 255 ! Do we have this target in our database ? 256 256 !- 257 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)257 CALL get_findkey (1,target,pos) 258 258 !- 259 259 tmp_ret_val(1) = ret_val … … 264 264 !-- Put the data into the database 265 265 CALL get_wdb & 266 & (target, target_sig,status,fileorig,1,r_val=tmp_ret_val)266 & (target,status,fileorig,1,r_val=tmp_ret_val) 267 267 ELSE 268 268 !-- Get the value out of the database … … 275 275 SUBROUTINE getinr1d (target,ret_val) 276 276 !--------------------------------------------------------------------- 277 !- See getinrs for details. It is the same thing but for a vector278 !---------------------------------------------------------------------279 277 IMPLICIT NONE 280 278 !- … … 284 282 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 285 283 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) 284 INTEGER :: pos,size_of_in,status=0,fileorig 285 !--------------------------------------------------------------------- 292 286 !- 293 287 ! Do we have this target in our database ? 294 288 !- 295 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)289 CALL get_findkey (1,target,pos) 296 290 !- 297 291 size_of_in = SIZE(ret_val) … … 310 304 !-- Put the data into the database 311 305 CALL get_wdb & 312 & (target, target_sig,status,fileorig,size_of_in,r_val=tmp_ret_val)306 & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) 313 307 ELSE 314 308 !-- Get the value out of the database … … 321 315 SUBROUTINE getinr2d (target,ret_val) 322 316 !--------------------------------------------------------------------- 323 !- See getinrs for details. It is the same thing but for a matrix324 !---------------------------------------------------------------------325 317 IMPLICIT NONE 326 318 !- … … 330 322 REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 331 323 INTEGER,SAVE :: tmp_ret_size = 0 332 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig324 INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig 333 325 INTEGER :: jl,jj,ji 334 326 !--------------------------------------------------------------------- 335 327 !- 336 ! Compute the signature of the target337 !-338 CALL gensig (target,target_sig)339 !-340 328 ! Do we have this target in our database ? 341 329 !- 342 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)330 CALL get_findkey (1,target,pos) 343 331 !- 344 332 size_of_in = SIZE(ret_val) … … 366 354 !-- Put the data into the database 367 355 CALL get_wdb & 368 & (target, target_sig,status,fileorig,size_of_in,r_val=tmp_ret_val)356 & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) 369 357 ELSE 370 358 !-- Get the value out of the database … … 386 374 SUBROUTINE getincs (target,ret_val) 387 375 !--------------------------------------------------------------------- 388 !- Get a CHARACTER scalar. We first check if we find it389 !- in the database and if not we get it from the run.def390 !-391 !- getinc1d and getinc2d are written on the same pattern392 !---------------------------------------------------------------------393 376 IMPLICIT NONE 394 377 !- … … 397 380 !- 398 381 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) 382 INTEGER :: pos,status=0,fileorig 383 !--------------------------------------------------------------------- 405 384 !- 406 385 ! Do we have this target in our database ? 407 386 !- 408 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)387 CALL get_findkey (1,target,pos) 409 388 !- 410 389 tmp_ret_val(1) = ret_val … … 415 394 !-- Put the data into the database 416 395 CALL get_wdb & 417 & (target, target_sig,status,fileorig,1,c_val=tmp_ret_val)396 & (target,status,fileorig,1,c_val=tmp_ret_val) 418 397 ELSE 419 398 !-- Get the value out of the database … … 426 405 SUBROUTINE getinc1d (target,ret_val) 427 406 !--------------------------------------------------------------------- 428 !- See getincs for details. It is the same thing but for a vector429 !---------------------------------------------------------------------430 407 IMPLICIT NONE 431 408 !- … … 435 412 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 436 413 INTEGER,SAVE :: tmp_ret_size = 0 437 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 438 !--------------------------------------------------------------------- 439 !- 440 ! Compute the signature of the target 441 !- 442 CALL gensig (target,target_sig) 414 INTEGER :: pos,size_of_in,status=0,fileorig 415 !--------------------------------------------------------------------- 443 416 !- 444 417 ! Do we have this target in our database ? 445 418 !- 446 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)419 CALL get_findkey (1,target,pos) 447 420 !- 448 421 size_of_in = SIZE(ret_val) … … 461 434 !-- Put the data into the database 462 435 CALL get_wdb & 463 & (target, target_sig,status,fileorig,size_of_in,c_val=tmp_ret_val)436 & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) 464 437 ELSE 465 438 !-- Get the value out of the database … … 472 445 SUBROUTINE getinc2d (target,ret_val) 473 446 !--------------------------------------------------------------------- 474 !- See getincs for details. It is the same thing but for a matrix475 !---------------------------------------------------------------------476 447 IMPLICIT NONE 477 448 !- … … 481 452 CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 482 453 INTEGER,SAVE :: tmp_ret_size = 0 483 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig454 INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig 484 455 INTEGER :: jl,jj,ji 485 456 !--------------------------------------------------------------------- 486 457 !- 487 ! Compute the signature of the target488 !-489 CALL gensig (target,target_sig)490 !-491 458 ! Do we have this target in our database ? 492 459 !- 493 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)460 CALL get_findkey (1,target,pos) 494 461 !- 495 462 size_of_in = SIZE(ret_val) … … 517 484 !-- Put the data into the database 518 485 CALL get_wdb & 519 & (target, target_sig,status,fileorig,size_of_in,c_val=tmp_ret_val)486 & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) 520 487 ELSE 521 488 !-- Get the value out of the database … … 537 504 SUBROUTINE getinls (target,ret_val) 538 505 !--------------------------------------------------------------------- 539 !- Get a logical scalar. We first check if we find it540 !- in the database and if not we get it from the run.def541 !-542 !- getinl1d and getinl2d are written on the same pattern543 !---------------------------------------------------------------------544 506 IMPLICIT NONE 545 507 !- … … 548 510 !- 549 511 LOGICAL,DIMENSION(1) :: tmp_ret_val 550 INTEGER :: target_sig,pos,status=0,fileorig 551 !--------------------------------------------------------------------- 552 !- 553 ! Compute the signature of the target 554 !- 555 CALL gensig (target,target_sig) 512 INTEGER :: pos,status=0,fileorig 513 !--------------------------------------------------------------------- 556 514 !- 557 515 ! Do we have this target in our database ? 558 516 !- 559 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)517 CALL get_findkey (1,target,pos) 560 518 !- 561 519 tmp_ret_val(1) = ret_val … … 566 524 !-- Put the data into the database 567 525 CALL get_wdb & 568 & (target, target_sig,status,fileorig,1,l_val=tmp_ret_val)526 & (target,status,fileorig,1,l_val=tmp_ret_val) 569 527 ELSE 570 528 !-- Get the value out of the database … … 577 535 SUBROUTINE getinl1d (target,ret_val) 578 536 !--------------------------------------------------------------------- 579 !- See getinls for details. It is the same thing but for a vector580 !---------------------------------------------------------------------581 537 IMPLICIT NONE 582 538 !- … … 586 542 LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 587 543 INTEGER,SAVE :: tmp_ret_size = 0 588 INTEGER :: target_sig,pos,size_of_in,status=0,fileorig 589 !--------------------------------------------------------------------- 590 !- 591 ! Compute the signature of the target 592 !- 593 CALL gensig (target,target_sig) 544 INTEGER :: pos,size_of_in,status=0,fileorig 545 !--------------------------------------------------------------------- 594 546 !- 595 547 ! Do we have this target in our database ? 596 548 !- 597 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)549 CALL get_findkey (1,target,pos) 598 550 !- 599 551 size_of_in = SIZE(ret_val) … … 612 564 !-- Put the data into the database 613 565 CALL get_wdb & 614 & (target, target_sig,status,fileorig,size_of_in,l_val=tmp_ret_val)566 & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) 615 567 ELSE 616 568 !-- Get the value out of the database … … 623 575 SUBROUTINE getinl2d (target,ret_val) 624 576 !--------------------------------------------------------------------- 625 !- See getinls for details. It is the same thing but for a matrix626 !---------------------------------------------------------------------627 577 IMPLICIT NONE 628 578 !- … … 632 582 LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val 633 583 INTEGER,SAVE :: tmp_ret_size = 0 634 INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig584 INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig 635 585 INTEGER :: jl,jj,ji 636 586 !--------------------------------------------------------------------- 637 587 !- 638 ! Compute the signature of the target639 !-640 CALL gensig (target,target_sig)641 !-642 588 ! Do we have this target in our database ? 643 589 !- 644 CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)590 CALL get_findkey (1,target,pos) 645 591 !- 646 592 size_of_in = SIZE(ret_val) … … 668 614 !-- Put the data into the database 669 615 CALL get_wdb & 670 & (target, target_sig,status,fileorig,size_of_in,l_val=tmp_ret_val)616 & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) 671 617 ELSE 672 618 !-- Get the value out of the database … … 710 656 INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err 711 657 CHARACTER(LEN=n_d_fmt) :: cnt 712 CHARACTER(LEN=37) :: full_target713 658 CHARACTER(LEN=80) :: str_READ,str_READ_lower 714 659 CHARACTER(LEN=9) :: c_vtyp 715 INTEGER :: full_target_sig716 660 LOGICAL,DIMENSION(:),ALLOCATABLE :: found 717 661 LOGICAL :: def_beha,compressed … … 749 693 !--- 750 694 !-- First try the target as it is 751 full_target = target 752 CALL gensig (full_target,full_target_sig) 753 CALL find_sig (nb_lines,targetlist,full_target, & 754 & targetsiglist,full_target_sig,pos) 695 CALL get_findkey (2,target,pos) 755 696 !--- 756 697 !-- Another try … … 758 699 IF (pos < 0) THEN 759 700 WRITE(UNIT=cnt,FMT=c_i_fmt) it 760 full_target = TRIM(target)//'__'//cnt 761 CALL gensig (full_target,full_target_sig) 762 CALL find_sig (nb_lines,targetlist,full_target, & 763 & targetsiglist,full_target_sig,pos) 701 CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) 764 702 ENDIF 765 703 !--- … … 818 756 ENDIF 819 757 !----- 820 targetsiglist(pos) = -1821 !-----822 758 IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN 823 759 !------- … … 919 855 CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val 920 856 !- 921 INTEGER :: k_typ 857 INTEGER :: k_typ,k_beg,k_end 922 858 CHARACTER(LEN=9) :: c_vtyp 923 859 !--------------------------------------------------------------------- … … 931 867 ENDIF 932 868 !- 933 IF (key type(pos)/= k_typ) THEN869 IF (key_tab(pos)%keytype /= k_typ) THEN 934 870 CALL ipslerr (3,'get_rdb', & 935 871 & 'Wrong data type for keyword '//TRIM(target), & … … 937 873 ENDIF 938 874 !- 939 IF (key compress(pos)> 0) THEN940 IF ( (key compress(pos)/= size_of_in) &941 & .OR.(key memlen(pos)/= 1) ) THEN875 IF (key_tab(pos)%keycompress > 0) THEN 876 IF ( (key_tab(pos)%keycompress /= size_of_in) & 877 & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN 942 878 CALL ipslerr (3,'get_rdb', & 943 879 & 'Wrong compression length','for keyword '//TRIM(target),' ') … … 945 881 SELECT CASE (k_typ) 946 882 CASE(k_i) 947 i_val(1:size_of_in) = i_mem(key memstart(pos))883 i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) 948 884 CASE(k_r) 949 r_val(1:size_of_in) = r_mem(key memstart(pos))885 r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) 950 886 END SELECT 951 887 ENDIF 952 888 ELSE 953 IF (key memlen(pos)/= size_of_in) THEN889 IF (key_tab(pos)%keymemlen /= size_of_in) THEN 954 890 CALL ipslerr (3,'get_rdb', & 955 891 & 'Wrong array length','for keyword '//TRIM(target),' ') 956 892 ELSE 893 k_beg = key_tab(pos)%keymemstart 894 k_end = k_beg+key_tab(pos)%keymemlen-1 957 895 SELECT CASE (k_typ) 958 896 CASE(k_i) 959 i_val(1:size_of_in) = & 960 & i_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 897 i_val(1:size_of_in) = i_mem(k_beg:k_end) 961 898 CASE(k_r) 962 r_val(1:size_of_in) = & 963 & r_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 899 r_val(1:size_of_in) = r_mem(k_beg:k_end) 964 900 CASE(k_c) 965 c_val(1:size_of_in) = & 966 & c_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 901 c_val(1:size_of_in) = c_mem(k_beg:k_end) 967 902 CASE(k_l) 968 l_val(1:size_of_in) = & 969 & l_mem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1) 903 l_val(1:size_of_in) = l_mem(k_beg:k_end) 970 904 END SELECT 971 905 ENDIF … … 975 909 !=== 976 910 SUBROUTINE get_wdb & 977 & (target, target_sig,status,fileorig,size_of_in, &911 & (target,status,fileorig,size_of_in, & 978 912 & i_val,r_val,c_val,l_val) 979 913 !--------------------------------------------------------------------- … … 983 917 !- 984 918 CHARACTER(LEN=*) :: target 985 INTEGER :: target_sig,status,fileorig,size_of_in919 INTEGER :: status,fileorig,size_of_in 986 920 INTEGER,DIMENSION(:),OPTIONAL :: i_val 987 921 REAL,DIMENSION(:),OPTIONAL :: r_val … … 991 925 INTEGER :: k_typ 992 926 CHARACTER(LEN=9) :: c_vtyp 993 INTEGER :: k_mempos,k_memsize,k_ len927 INTEGER :: k_mempos,k_memsize,k_beg,k_end 994 928 LOGICAL :: l_cmp 995 929 !--------------------------------------------------------------------- … … 1027 961 ! Fill out the items of the data base 1028 962 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 963 key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) 964 key_tab(nb_keys)%keystatus = status 965 key_tab(nb_keys)%keytype = k_typ 966 key_tab(nb_keys)%keyfromfile = fileorig 967 key_tab(nb_keys)%keymemstart = k_mempos+1 1035 968 IF (l_cmp) THEN 1036 key compress(nb_keys)= size_of_in1037 key memlen(nb_keys)= 1969 key_tab(nb_keys)%keycompress = size_of_in 970 key_tab(nb_keys)%keymemlen = 1 1038 971 ELSE 1039 key compress(nb_keys)= -11040 key memlen(nb_keys)= size_of_in972 key_tab(nb_keys)%keycompress = -1 973 key_tab(nb_keys)%keymemlen = size_of_in 1041 974 ENDIF 1042 975 !- 1043 976 ! 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 977 IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & 978 & > k_memsize) THEN 979 CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) 980 ENDIF 981 !- 982 k_beg = key_tab(nb_keys)%keymemstart 983 k_end = k_beg+key_tab(nb_keys)%keymemlen-1 1049 984 SELECT CASE (k_typ) 1050 985 CASE(k_i) 1051 i_mem(k eymemstart(nb_keys):k_len) = i_val(1:keymemlen(nb_keys))1052 i_mempos = k_ len986 i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) 987 i_mempos = k_end 1053 988 CASE(k_r) 1054 r_mem(k eymemstart(nb_keys):k_len) = r_val(1:keymemlen(nb_keys))1055 r_mempos = k_ len989 r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) 990 r_mempos = k_end 1056 991 CASE(k_c) 1057 c_mem(k eymemstart(nb_keys):k_len) = c_val(1:keymemlen(nb_keys))1058 c_mempos = k_ len992 c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) 993 c_mempos = k_end 1059 994 CASE(k_l) 1060 l_mem(k eymemstart(nb_keys):k_len) = l_val(1:keymemlen(nb_keys))1061 l_mempos = k_ len995 l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) 996 l_mempos = k_end 1062 997 END SELECT 1063 998 !--------------------- … … 1190 1125 targetlist(nb_lines) = & 1191 1126 & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt 1192 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))1193 1127 key_str = last_key(1:LEN_TRIM(last_key)) 1194 1128 ENDIF … … 1340 1274 ENDIF 1341 1275 !----- 1342 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))1343 1276 fichier(nb_lines) = NEW_str(1:len_str) 1344 1277 fromfile(nb_lines) = current … … 1369 1302 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1370 1303 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1371 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))1372 1304 fromfile(nb_lines) = current 1373 1305 !- … … 1393 1325 & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1394 1326 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1395 CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))1396 1327 fromfile(nb_lines) = current 1397 1328 !- … … 1414 1345 IMPLICIT NONE 1415 1346 !- 1416 INTEGER :: line, found1347 INTEGER :: line,n_k,k 1417 1348 !--------------------------------------------------------------------- 1418 1349 DO line=1,nb_lines-1 1419 1350 !- 1420 CALL find_sig & 1421 & (nb_lines-line,targetlist(line+1:nb_lines),targetlist(line), & 1422 & targetsiglist(line+1:nb_lines),targetsiglist(line),found) 1351 n_k = 0 1352 DO k=line+1,nb_lines 1353 IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN 1354 n_k = k 1355 EXIT 1356 ENDIF 1357 ENDDO 1423 1358 !--- 1424 1359 !-- IF we have found it we have a problem to solve. 1425 1360 !--- 1426 IF (found > 0) THEN 1427 WRITE(*,*) 'COUNT : ', & 1428 & COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1) 1429 !----- 1361 IF (n_k > 0) THEN 1362 WRITE(*,*) 'COUNT : ',n_k 1430 1363 WRITE(*,*) & 1431 & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))1364 & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) 1432 1365 WRITE(*,*) & 1433 & 'getin_checkcohe : The following values were encoutered :'1366 & 'getin_checkcohe : The following values were encoutered :' 1434 1367 WRITE(*,*) & 1435 & ' ',TRIM(targetlist(line)), & 1436 & targetsiglist(line),' == ',fichier(line) 1368 & ' ',TRIM(targetlist(line)),' == ',fichier(line) 1437 1369 WRITE(*,*) & 1438 & ' ',TRIM(targetlist(line+found)), & 1439 & targetsiglist(line+found),' == ',fichier(line+found) 1370 & ' ',TRIM(targetlist(k)),' == ',fichier(k) 1440 1371 WRITE(*,*) & 1441 & 'getin_checkcohe : We will keep only the last value' 1442 !----- 1443 targetsiglist(line) = 1 1372 & 'getin_checkcohe : We will keep only the last value' 1373 targetlist(line) = ' ' 1444 1374 ENDIF 1445 1375 ENDDO … … 1488 1418 IMPLICIT NONE 1489 1419 !- 1420 TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab 1490 1421 INTEGER,ALLOCATABLE :: tmp_int(:) 1491 1422 CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:) … … 1494 1425 CHARACTER(LEN=20) :: c_tmp 1495 1426 !--------------------------------------------------------------------- 1496 !-1497 ! Either nothing exists in these arrays and it is easy to do1498 !-1499 1427 IF (keymemsize == 0) THEN 1500 1428 !--- 1429 !-- Nothing exists in memory arrays and it is easy to do. 1430 !--- 1501 1431 WRITE (UNIT=c_tmp,FMT=*) memslabs 1502 !--- 1503 ALLOCATE(keysig(memslabs),stat=ier) 1432 ALLOCATE(key_tab(memslabs),stat=ier) 1504 1433 IF (ier /= 0) THEN 1505 1434 CALL ipslerr (3,'getin_allockeys', & 1506 & 'Can not allocate key sig', &1435 & 'Can not allocate key_tab', & 1507 1436 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1508 1437 ENDIF 1509 !--- 1510 ALLOCATE(keystr(memslabs),stat=ier) 1438 nb_keys = 0 1439 keymemsize = memslabs 1440 key_tab(:)%keycompress = -1 1441 !--- 1442 ELSE 1443 !--- 1444 !-- There is something already in the memory, 1445 !-- we need to transfer and reallocate. 1446 !--- 1447 WRITE (UNIT=c_tmp,FMT=*) keymemsize 1448 ALLOCATE(tmp_key_tab(keymemsize),stat=ier) 1511 1449 IF (ier /= 0) THEN 1512 1450 CALL ipslerr (3,'getin_allockeys', & 1513 & 'Can not allocate keystr', &1451 & 'Can not allocate tmp_key_tab', & 1514 1452 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1515 1453 ENDIF 1516 !--- 1517 ALLOCATE(keystatus(memslabs),stat=ier) 1454 WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs 1455 tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) 1456 DEALLOCATE(key_tab) 1457 ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) 1518 1458 IF (ier /= 0) THEN 1519 1459 CALL ipslerr (3,'getin_allockeys', & 1520 & 'Can not allocate key status', &1460 & 'Can not allocate key_tab', & 1521 1461 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1522 1462 ENDIF 1523 !--- 1524 ALLOCATE(keytype(memslabs),stat=ier) 1525 IF (ier /= 0) THEN 1526 CALL ipslerr (3,'getin_allockeys', & 1527 & 'Can not allocate keytype', & 1528 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1529 ENDIF 1530 !--- 1531 ALLOCATE(keycompress(memslabs),stat=ier) 1532 IF (ier /= 0) THEN 1533 CALL ipslerr (3,'getin_allockeys', & 1534 & 'Can not allocate keycompress', & 1535 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1536 ENDIF 1537 !--- 1538 ALLOCATE(keyfromfile(memslabs),stat=ier) 1539 IF (ier /= 0) THEN 1540 CALL ipslerr (3,'getin_allockeys', & 1541 & 'Can not allocate keyfromfile', & 1542 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1543 ENDIF 1544 !--- 1545 ALLOCATE(keymemstart(memslabs),stat=ier) 1546 IF (ier /= 0) THEN 1547 CALL ipslerr (3,'getin_allockeys', & 1548 & 'Can not allocate keymemstart', & 1549 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1550 ENDIF 1551 !--- 1552 ALLOCATE(keymemlen(memslabs),stat=ier) 1553 IF (ier /= 0) THEN 1554 CALL ipslerr (3,'getin_allockeys', & 1555 & 'Can not allocate keymemlen', & 1556 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1557 ENDIF 1558 !--- 1559 nb_keys = 0 1560 keymemsize = memslabs 1561 keycompress(:) = -1 1562 !--- 1563 ELSE 1564 !--- 1565 !-- There is something already in the memory, 1566 !-- we need to transfer and reallocate. 1567 !--- 1568 WRITE (UNIT=c_tmp,FMT=*) keymemsize 1569 !--- 1570 ALLOCATE(tmp_str(keymemsize),stat=ier) 1571 IF (ier /= 0) THEN 1572 CALL ipslerr (3,'getin_allockeys', & 1573 & 'Can not allocate tmp_str', & 1574 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1575 ENDIF 1576 !--- 1577 ALLOCATE(tmp_int(keymemsize),stat=ier) 1578 IF (ier /= 0) THEN 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 !--- 1586 tmp_int(1:keymemsize) = keysig(1:keymemsize) 1587 DEALLOCATE(keysig) 1588 ALLOCATE(keysig(keymemsize+memslabs),stat=ier) 1589 IF (ier /= 0) THEN 1590 CALL ipslerr (3,'getin_allockeys', & 1591 & 'Can not allocate keysig', & 1592 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1593 ENDIF 1594 keysig(1:keymemsize) = tmp_int(1:keymemsize) 1595 !--- 1596 tmp_str(1:keymemsize) = keystr(1:keymemsize) 1597 DEALLOCATE(keystr) 1598 ALLOCATE(keystr(keymemsize+memslabs),stat=ier) 1599 IF (ier /= 0) THEN 1600 CALL ipslerr (3,'getin_allockeys', & 1601 & 'Can not allocate keystr', & 1602 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1603 ENDIF 1604 keystr(1:keymemsize) = tmp_str(1:keymemsize) 1605 !--- 1606 tmp_int(1:keymemsize) = keystatus(1:keymemsize) 1607 DEALLOCATE(keystatus) 1608 ALLOCATE(keystatus(keymemsize+memslabs),stat=ier) 1609 IF (ier /= 0) THEN 1610 CALL ipslerr (3,'getin_allockeys', & 1611 & 'Can not allocate keystatus', & 1612 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1613 ENDIF 1614 keystatus(1:keymemsize) = tmp_int(1:keymemsize) 1615 !--- 1616 tmp_int(1:keymemsize) = keytype(1:keymemsize) 1617 DEALLOCATE(keytype) 1618 ALLOCATE(keytype(keymemsize+memslabs),stat=ier) 1619 IF (ier /= 0) THEN 1620 CALL ipslerr (3,'getin_allockeys', & 1621 & 'Can not allocate keytype', & 1622 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1623 ENDIF 1624 keytype(1:keymemsize) = tmp_int(1:keymemsize) 1625 !--- 1626 tmp_int(1:keymemsize) = keycompress(1:keymemsize) 1627 DEALLOCATE(keycompress) 1628 ALLOCATE(keycompress(keymemsize+memslabs),stat=ier) 1629 IF (ier /= 0) THEN 1630 CALL ipslerr (3,'getin_allockeys', & 1631 & 'Can not allocate keycompress', & 1632 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1633 ENDIF 1634 keycompress(:) = -1 1635 keycompress(1:keymemsize) = tmp_int(1:keymemsize) 1636 !--- 1637 tmp_int(1:keymemsize) = keyfromfile(1:keymemsize) 1638 DEALLOCATE(keyfromfile) 1639 ALLOCATE(keyfromfile(keymemsize+memslabs),stat=ier) 1640 IF (ier /= 0) THEN 1641 CALL ipslerr (3,'getin_allockeys', & 1642 & 'Can not allocate keyfromfile', & 1643 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1644 ENDIF 1645 keyfromfile(1:keymemsize) = tmp_int(1:keymemsize) 1646 !--- 1647 tmp_int(1:keymemsize) = keymemstart(1:keymemsize) 1648 DEALLOCATE(keymemstart) 1649 ALLOCATE(keymemstart(keymemsize+memslabs),stat=ier) 1650 IF (ier /= 0) THEN 1651 CALL ipslerr (3,'getin_allockeys', & 1652 & 'Can not allocate keymemstart', & 1653 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1654 ENDIF 1655 keymemstart(1:keymemsize) = tmp_int(1:keymemsize) 1656 !--- 1657 tmp_int(1:keymemsize) = keymemlen(1:keymemsize) 1658 DEALLOCATE(keymemlen) 1659 ALLOCATE(keymemlen(keymemsize+memslabs),stat=ier) 1660 IF (ier /= 0) THEN 1661 CALL ipslerr (3,'getin_allockeys', & 1662 & 'Can not allocate keymemlen', & 1663 & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1664 ENDIF 1665 keymemlen(1:keymemsize) = tmp_int(1:keymemsize) 1666 !--- 1463 key_tab(:)%keycompress = -1 1464 key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) 1465 DEALLOCATE(tmp_key_tab) 1667 1466 keymemsize = keymemsize+memslabs 1668 !---1669 DEALLOCATE(tmp_int)1670 DEALLOCATE(tmp_str)1671 1467 ENDIF 1672 1468 !----------------------------- … … 1678 1474 !--------------------------------------------------------------------- 1679 1475 !- Allocate the memory of the data base for all 4 types of memory 1680 !- INTEGER / REAL / CHAR / LOGICAL1476 !- INTEGER / REAL / CHARACTER / LOGICAL 1681 1477 !--------------------------------------------------------------------- 1682 1478 IMPLICIT NONE … … 1685 1481 !- 1686 1482 INTEGER,ALLOCATABLE :: tmp_int(:) 1483 REAL,ALLOCATABLE :: tmp_real(:) 1687 1484 CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) 1688 REAL,ALLOCATABLE :: tmp_real(:)1689 1485 LOGICAL,ALLOCATABLE :: tmp_logic(:) 1690 1486 INTEGER :: ier … … 1825 1621 !- 1826 1622 SUBROUTINE getin_dump (fileprefix) 1827 !---------------------------------------------------------------------1828 !- This subroutine will dump the content of the database into file1829 !- which has the same format as the run.def. The idea is that the user1830 !- can see which parameters were used and re-use the file for another1831 !- run.1832 !-1833 !- The argument file allows the user to change the name of the file1834 !- in which the data will be archived1835 1623 !--------------------------------------------------------------------- 1836 1624 IMPLICIT NONE … … 1875 1663 !----- 1876 1664 !---- Is this key from this file ? 1877 IF (key fromfile(ikey)== if) THEN1665 IF (key_tab(ikey)%keyfromfile == if) THEN 1878 1666 !------- 1879 1667 !------ Write some comments 1880 1668 WRITE(22,*) '#' 1881 SELECT CASE (key status(ikey))1669 SELECT CASE (key_tab(ikey)%keystatus) 1882 1670 CASE(1) 1883 1671 WRITE(22,*) '# Values of ', & 1884 & TRIM(key str(ikey)),' comes from the run.def.'1672 & TRIM(key_tab(ikey)%keystr),' comes from the run.def.' 1885 1673 CASE(2) 1886 1674 WRITE(22,*) '# Values of ', & 1887 & TRIM(key str(ikey)),' are all defaults.'1675 & TRIM(key_tab(ikey)%keystr),' are all defaults.' 1888 1676 CASE(3) 1889 1677 WRITE(22,*) '# Values of ', & 1890 & TRIM(keystr(ikey)),' are a mix of run.def and defaults.' 1678 & TRIM(key_tab(ikey)%keystr), & 1679 & ' are a mix of run.def and defaults.' 1891 1680 CASE DEFAULT 1892 1681 WRITE(22,*) '# Dont know from where the value of ', & 1893 & TRIM(key str(ikey)),' comes.'1682 & TRIM(key_tab(ikey)%keystr),' comes.' 1894 1683 END SELECT 1895 1684 WRITE(22,*) '#' 1896 1685 !------- 1897 1686 !------ Write the values 1898 SELECT CASE (key type(ikey))1687 SELECT CASE (key_tab(ikey)%keytype) 1899 1688 CASE(k_i) 1900 IF (key memlen(ikey)== 1) THEN1901 IF (key compress(ikey)< 0) THEN1689 IF (key_tab(ikey)%keymemlen == 1) THEN 1690 IF (key_tab(ikey)%keycompress < 0) THEN 1902 1691 WRITE(22,*) & 1903 & TRIM(keystr(ikey)),' = ',i_mem(keymemstart(ikey)) 1692 & TRIM(key_tab(ikey)%keystr), & 1693 & ' = ',i_mem(key_tab(ikey)%keymemstart) 1904 1694 ELSE 1905 1695 WRITE(22,*) & 1906 & TRIM(keystr(ikey)),' = ',keycompress(ikey), & 1907 & ' * ',i_mem(keymemstart(ikey)) 1696 & TRIM(key_tab(ikey)%keystr), & 1697 & ' = ',key_tab(ikey)%keycompress, & 1698 & ' * ',i_mem(key_tab(ikey)%keymemstart) 1908 1699 ENDIF 1909 1700 ELSE 1910 DO iv=0,key memlen(ikey)-11701 DO iv=0,key_tab(ikey)%keymemlen-1 1911 1702 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1912 1703 WRITE(22,*) & 1913 & TRIM(keystr(ikey)),'__',TRIM(ADJUSTL(c_tmp)), & 1914 & ' = ',i_mem(keymemstart(ikey)+iv) 1704 & TRIM(key_tab(ikey)%keystr), & 1705 & '__',TRIM(ADJUSTL(c_tmp)), & 1706 & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) 1915 1707 ENDDO 1916 1708 ENDIF 1917 1709 CASE(k_r) 1918 IF (key memlen(ikey)== 1) THEN1919 IF (key compress(ikey)< 0) THEN1710 IF (key_tab(ikey)%keymemlen == 1) THEN 1711 IF (key_tab(ikey)%keycompress < 0) THEN 1920 1712 WRITE(22,*) & 1921 & TRIM(keystr(ikey)),' = ',r_mem(keymemstart(ikey)) 1713 & TRIM(key_tab(ikey)%keystr), & 1714 & ' = ',r_mem(key_tab(ikey)%keymemstart) 1922 1715 ELSE 1923 1716 WRITE(22,*) & 1924 & TRIM(keystr(ikey)),' = ',keycompress(ikey),& 1925 & ' * ',r_mem(keymemstart(ikey)) 1717 & TRIM(key_tab(ikey)%keystr), & 1718 & ' = ',key_tab(ikey)%keycompress, & 1719 & ' * ',r_mem(key_tab(ikey)%keymemstart) 1926 1720 ENDIF 1927 1721 ELSE 1928 DO iv=0,key memlen(ikey)-11722 DO iv=0,key_tab(ikey)%keymemlen-1 1929 1723 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1930 1724 WRITE(22,*) & 1931 & TRIM(key str(ikey)),'__',TRIM(ADJUSTL(c_tmp)), &1932 & ' = ',r_mem(key memstart(ikey)+iv)1725 & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & 1726 & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) 1933 1727 ENDDO 1934 1728 ENDIF 1935 1729 CASE(k_c) 1936 IF (keymemlen(ikey) == 1) THEN 1937 tmp_str = c_mem(keymemstart(ikey)) 1938 WRITE(22,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str) 1730 IF (key_tab(ikey)%keymemlen == 1) THEN 1731 tmp_str = c_mem(key_tab(ikey)%keymemstart) 1732 WRITE(22,*) TRIM(key_tab(ikey)%keystr), & 1733 & ' = ',TRIM(tmp_str) 1939 1734 ELSE 1940 DO iv=0,key memlen(ikey)-11735 DO iv=0,key_tab(ikey)%keymemlen-1 1941 1736 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1942 tmp_str = c_mem(key memstart(ikey)+iv)1737 tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) 1943 1738 WRITE(22,*) & 1944 & TRIM(keystr(ikey)),'__',TRIM(ADJUSTL(c_tmp)), & 1739 & TRIM(key_tab(ikey)%keystr), & 1740 & '__',TRIM(ADJUSTL(c_tmp)), & 1945 1741 & ' = ',TRIM(tmp_str) 1946 1742 ENDDO 1947 1743 ENDIF 1948 1744 CASE(k_l) 1949 IF (key memlen(ikey)== 1) THEN1950 IF (l_mem(key memstart(ikey))) THEN1951 WRITE(22,*) TRIM(key str(ikey)),' = TRUE '1745 IF (key_tab(ikey)%keymemlen == 1) THEN 1746 IF (l_mem(key_tab(ikey)%keymemstart)) THEN 1747 WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' 1952 1748 ELSE 1953 WRITE(22,*) TRIM(key str(ikey)),' = FALSE '1749 WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' 1954 1750 ENDIF 1955 1751 ELSE 1956 DO iv=0,key memlen(ikey)-11752 DO iv=0,key_tab(ikey)%keymemlen-1 1957 1753 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1958 IF (l_mem(key memstart(ikey)+iv)) THEN1959 WRITE(22,*) TRIM(key str(ikey)),'__', &1754 IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN 1755 WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & 1960 1756 & TRIM(ADJUSTL(c_tmp)),' = TRUE ' 1961 1757 ELSE 1962 WRITE(22,*) TRIM(key str(ikey)),'__', &1758 WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & 1963 1759 & TRIM(ADJUSTL(c_tmp)),' = FALSE ' 1964 1760 ENDIF … … 1967 1763 CASE DEFAULT 1968 1764 CALL ipslerr (3,'getin_dump', & 1969 & 'Unknown type for variable '//TRIM(keystr(ikey)),' ',' ') 1765 & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & 1766 & ' ',' ') 1970 1767 END SELECT 1971 1768 ENDIF … … 2014 1811 END SUBROUTINE get_qtyp 2015 1812 !=== 1813 SUBROUTINE get_findkey (i_tab,c_key,pos) 1814 !--------------------------------------------------------------------- 1815 !- This subroutine looks for a key in a table 1816 !--------------------------------------------------------------------- 1817 !- INPUT 1818 !- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr 1819 !- 2 -> search in targetlist(1:nb_lines) 1820 !- c_key : Name of the key we are looking for 1821 !- OUTPUT 1822 !- pos : -1 if key not found, else value in the table 1823 !--------------------------------------------------------------------- 1824 IMPLICIT NONE 1825 !- 1826 INTEGER,INTENT(in) :: i_tab 1827 CHARACTER(LEN=*),INTENT(in) :: c_key 1828 INTEGER,INTENT(out) :: pos 1829 !- 1830 INTEGER :: ikey_max,ikey 1831 CHARACTER(LEN=l_n) :: c_q_key 1832 !--------------------------------------------------------------------- 1833 pos = -1 1834 IF (i_tab == 1) THEN 1835 ikey_max = nb_keys 1836 ELSEIF (i_tab == 2) THEN 1837 ikey_max = nb_lines 1838 ELSE 1839 ikey_max = 0 1840 ENDIF 1841 IF ( ikey_max > 0 ) THEN 1842 DO ikey=1,ikey_max 1843 IF (i_tab == 1) THEN 1844 c_q_key = key_tab(ikey)%keystr 1845 ELSE 1846 c_q_key = targetlist(ikey) 1847 ENDIF 1848 IF (TRIM(c_q_key) == TRIM(c_key)) THEN 1849 pos = ikey 1850 EXIT 1851 ENDIF 1852 ENDDO 1853 ENDIF 1854 !------------------------- 1855 END SUBROUTINE get_findkey 1856 !=== 2016 1857 !------------------ 2017 1858 END MODULE getincom
Note: See TracChangeset
for help on using the changeset viewer.