Changeset 5087 for LMDZ6/branches/Amaury_dev/libf/misc/ioipsl_getincom.F90
- Timestamp:
- Jul 20, 2024, 12:00:23 PM (2 months ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Amaury_dev/libf/misc/ioipsl_getincom.F90
r1907 r5087 13 13 USE ioipsl_errioipsl, ONLY : ipslerr 14 14 USE ioipsl_stringop, & 15 &ONLY : nocomma,cmpblank,strlowercase15 ONLY : nocomma,cmpblank,strlowercase 16 16 !- 17 17 IMPLICIT NONE … … 39 39 !!-------------------------------------------------------------------- 40 40 MODULE PROCEDURE getinrs, getinr1d, getinr2d, & 41 &getinis, getini1d, getini2d, &42 &getincs, getinc1d, getinc2d, &43 &getinls, getinl1d, getinl2d41 getinis, getini1d, getini2d, & 42 getincs, getinc1d, getinc2d, & 43 getinls, getinl1d, getinl2d 44 44 END INTERFACE 45 45 !- … … 102 102 CHARACTER(LEN=l_n) :: keystr 103 103 INTEGER :: keystatus, keytype, keycompress, & 104 &keyfromfile, keymemstart, keymemlen104 keyfromfile, keymemstart, keymemlen 105 105 END TYPE t_key 106 106 !- … … 142 142 !-- Put the data into the database 143 143 CALL get_wdb & 144 &(target,status,fileorig,1,i_val=tmp_ret_val)144 (target,status,fileorig,1,i_val=tmp_ret_val) 145 145 ELSE 146 146 !-- Get the value out of the database … … 182 182 !-- Put the data into the database 183 183 CALL get_wdb & 184 &(target,status,fileorig,size_of_in,i_val=tmp_ret_val)184 (target,status,fileorig,size_of_in,i_val=tmp_ret_val) 185 185 ELSE 186 186 !-- Get the value out of the database … … 232 232 !-- Put the data into the database 233 233 CALL get_wdb & 234 &(target,status,fileorig,size_of_in,i_val=tmp_ret_val)234 (target,status,fileorig,size_of_in,i_val=tmp_ret_val) 235 235 ELSE 236 236 !-- Get the value out of the database … … 272 272 !-- Put the data into the database 273 273 CALL get_wdb & 274 &(target,status,fileorig,1,r_val=tmp_ret_val)274 (target,status,fileorig,1,r_val=tmp_ret_val) 275 275 ELSE 276 276 !-- Get the value out of the database … … 312 312 !-- Put the data into the database 313 313 CALL get_wdb & 314 &(target,status,fileorig,size_of_in,r_val=tmp_ret_val)314 (target,status,fileorig,size_of_in,r_val=tmp_ret_val) 315 315 ELSE 316 316 !-- Get the value out of the database … … 362 362 !-- Put the data into the database 363 363 CALL get_wdb & 364 &(target,status,fileorig,size_of_in,r_val=tmp_ret_val)364 (target,status,fileorig,size_of_in,r_val=tmp_ret_val) 365 365 ELSE 366 366 !-- Get the value out of the database … … 402 402 !-- Put the data into the database 403 403 CALL get_wdb & 404 &(target,status,fileorig,1,c_val=tmp_ret_val)404 (target,status,fileorig,1,c_val=tmp_ret_val) 405 405 ELSE 406 406 !-- Get the value out of the database … … 442 442 !-- Put the data into the database 443 443 CALL get_wdb & 444 &(target,status,fileorig,size_of_in,c_val=tmp_ret_val)444 (target,status,fileorig,size_of_in,c_val=tmp_ret_val) 445 445 ELSE 446 446 !-- Get the value out of the database … … 492 492 !-- Put the data into the database 493 493 CALL get_wdb & 494 &(target,status,fileorig,size_of_in,c_val=tmp_ret_val)494 (target,status,fileorig,size_of_in,c_val=tmp_ret_val) 495 495 ELSE 496 496 !-- Get the value out of the database … … 532 532 !-- Put the data into the database 533 533 CALL get_wdb & 534 &(target,status,fileorig,1,l_val=tmp_ret_val)534 (target,status,fileorig,1,l_val=tmp_ret_val) 535 535 ELSE 536 536 !-- Get the value out of the database … … 572 572 !-- Put the data into the database 573 573 CALL get_wdb & 574 &(target,status,fileorig,size_of_in,l_val=tmp_ret_val)574 (target,status,fileorig,size_of_in,l_val=tmp_ret_val) 575 575 ELSE 576 576 !-- Get the value out of the database … … 622 622 !-- Put the data into the database 623 623 CALL get_wdb & 624 &(target,status,fileorig,size_of_in,l_val=tmp_ret_val)624 (target,status,fileorig,size_of_in,l_val=tmp_ret_val) 625 625 ELSE 626 626 !-- Get the value out of the database … … 687 687 CASE DEFAULT 688 688 CALL ipslerr (3,'get_fil', & 689 &'Internal error','Unknown type of data',' ')689 'Internal error','Unknown type of data',' ') 690 690 END SELECT 691 691 !- … … 726 726 !----- 727 727 IF ( (TRIM(str_READ_lower) == 'def') & 728 &.OR.(TRIM(str_READ_lower) == 'default') ) THEN728 .OR.(TRIM(str_READ_lower) == 'default') ) THEN 729 729 def_beha = .TRUE. 730 730 ELSE … … 736 736 WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str 737 737 READ (UNIT=str_READ(1:len_str), & 738 &FMT=c_fmt,IOSTAT=io_err) i_val(it)738 FMT=c_fmt,IOSTAT=io_err) i_val(it) 739 739 CASE(k_r) 740 740 READ (UNIT=str_READ(1:len_str), & 741 &FMT=*,IOSTAT=io_err) r_val(it)741 FMT=*,IOSTAT=io_err) r_val(it) 742 742 CASE(k_c) 743 743 c_val(it) = str_READ(1:len_str) … … 746 746 ipos_fl = -1 747 747 ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & 748 &INDEX(str_READ_lower,'y'))748 INDEX(str_READ_lower,'y')) 749 749 ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & 750 &INDEX(str_READ_lower,'n'))750 INDEX(str_READ_lower,'n')) 751 751 IF (ipos_tr > 0) THEN 752 752 l_val(it) = .TRUE. … … 759 759 IF (io_err /= 0) THEN 760 760 CALL ipslerr (3,'get_fil', & 761 &'Target '//TRIM(target), &762 &'is not of '//TRIM(c_vtyp)//' type',' ')761 'Target '//TRIM(target), & 762 'is not of '//TRIM(c_vtyp)//' type',' ') 763 763 ENDIF 764 764 ENDIF … … 771 771 IF (compline(pos) /= nb_to_ret) THEN 772 772 CALL ipslerr (2,'get_fil', & 773 &'For key '//TRIM(target)//' we have a compressed field', &774 &'which does not have the right size.', &775 &'We will try to fix that.')773 'For key '//TRIM(target)//' we have a compressed field', & 774 'which does not have the right size.', & 775 'We will try to fix that.') 776 776 ENDIF 777 777 IF (k_typ == k_i) THEN … … 816 816 IF (status_cnt <= max_msgs) THEN 817 817 WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & 818 &ADVANCE='NO') TRIM(target)818 ADVANCE='NO') TRIM(target) 819 819 IF (nb_to_ret > 1) THEN 820 820 WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') … … 870 870 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 871 871 IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & 872 &.AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN872 .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN 873 873 CALL ipslerr (3,'get_rdb', & 874 &'Internal error','Unknown type of data',' ')874 'Internal error','Unknown type of data',' ') 875 875 ENDIF 876 876 !- 877 877 IF (key_tab(pos)%keytype /= k_typ) THEN 878 878 CALL ipslerr (3,'get_rdb', & 879 &'Wrong data type for keyword '//TRIM(target), &880 &'(NOT '//TRIM(c_vtyp)//')',' ')879 'Wrong data type for keyword '//TRIM(target), & 880 '(NOT '//TRIM(c_vtyp)//')',' ') 881 881 ENDIF 882 882 !- 883 883 IF (key_tab(pos)%keycompress > 0) THEN 884 884 IF ( (key_tab(pos)%keycompress /= size_of_in) & 885 &.OR.(key_tab(pos)%keymemlen /= 1) ) THEN885 .OR.(key_tab(pos)%keymemlen /= 1) ) THEN 886 886 CALL ipslerr (3,'get_rdb', & 887 &'Wrong compression length','for keyword '//TRIM(target),' ')887 'Wrong compression length','for keyword '//TRIM(target),' ') 888 888 ELSE 889 889 SELECT CASE (k_typ) … … 897 897 IF (key_tab(pos)%keymemlen /= size_of_in) THEN 898 898 CALL ipslerr (3,'get_rdb', & 899 &'Wrong array length','for keyword '//TRIM(target),' ')899 'Wrong array length','for keyword '//TRIM(target),' ') 900 900 ELSE 901 901 k_beg = key_tab(pos)%keymemstart … … 917 917 !=== 918 918 SUBROUTINE get_wdb & 919 &(target,status,fileorig,size_of_in, &920 &i_val,r_val,c_val,l_val)919 (target,status,fileorig,size_of_in, & 920 i_val,r_val,c_val,l_val) 921 921 !--------------------------------------------------------------------- 922 922 !- Write data into the data base … … 940 940 CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) 941 941 IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & 942 &.AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN942 .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN 943 943 CALL ipslerr (3,'get_wdb', & 944 &'Internal error','Unknown type of data',' ')944 'Internal error','Unknown type of data',' ') 945 945 ENDIF 946 946 !- … … 954 954 k_mempos = i_mempos; k_memsize = i_memsize; 955 955 l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & 956 &.AND.(size_of_in > compress_lim)956 .AND.(size_of_in > compress_lim) 957 957 CASE(k_r) 958 958 k_mempos = r_mempos; k_memsize = r_memsize; 959 959 l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & 960 &.AND.(size_of_in > compress_lim)960 .AND.(size_of_in > compress_lim) 961 961 CASE(k_c) 962 962 k_mempos = c_mempos; k_memsize = c_memsize; … … 984 984 ! Before writing the actual size lets see if we have the space 985 985 IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & 986 &> k_memsize) THEN986 > k_memsize) THEN 987 987 CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) 988 988 ENDIF … … 1070 1070 IF (io_err /= 0) THEN 1071 1071 CALL ipslerr (2,'getin_readdef', & 1072 &'Could not open file '//TRIM(filelist(current)),' ',' ')1072 'Could not open file '//TRIM(filelist(current)),' ',' ') 1073 1073 RETURN 1074 1074 ENDIF … … 1087 1087 IF (iund > 0) THEN 1088 1088 WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & 1089 &LEN_TRIM(key_str)-iund-11089 LEN_TRIM(key_str)-iund-1 1090 1090 READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & 1091 &FMT=c_fmt,IOSTAT=io_err) it1091 FMT=c_fmt,IOSTAT=io_err) it 1092 1092 IF ( (io_err == 0).AND.(it > 0) ) THEN 1093 1093 WRITE(UNIT=cnt,FMT=c_i_fmt) it … … 1095 1095 ELSE 1096 1096 CALL ipslerr (3,'getin_readdef', & 1097 &'A very strange key has just been found :', &1098 &TRIM(key_str),' ')1097 'A very strange key has just been found :', & 1098 TRIM(key_str),' ') 1099 1099 ENDIF 1100 1100 ENDIF … … 1106 1106 IF (check) THEN 1107 1107 WRITE(*,*) & 1108 &'--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)1108 '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) 1109 1109 ENDIF 1110 1110 !---- Decypher the content of NEW_str … … 1126 1126 IF (nb_lastkey /= 1) THEN 1127 1127 CALL ipslerr (3,'getin_readdef', & 1128 &'We can not have a scalar keyword', &1129 &'and a vector content',' ')1128 'We can not have a scalar keyword', & 1129 'and a vector content',' ') 1130 1130 ENDIF 1131 1131 !-------- The last keyword needs to be transformed into a vector. 1132 1132 WRITE(UNIT=cnt,FMT=c_i_fmt) 1 1133 1133 targetlist(nb_lines) = & 1134 &last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt1134 last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt 1135 1135 key_str = last_key(1:LEN_TRIM(last_key)) 1136 1136 ENDIF … … 1193 1193 IF (nbfiles+1 > max_files) THEN 1194 1194 CALL ipslerr (3,'getin_decrypt', & 1195 &'Too many files to include',' ',' ')1195 'Too many files to include',' ',' ') 1196 1196 ENDIF 1197 1197 !----- … … 1205 1205 IF (nbfiles+1 > max_files) THEN 1206 1206 CALL ipslerr (3,'getin_decrypt', & 1207 &'Too many files to include',' ',' ')1207 'Too many files to include',' ',' ') 1208 1208 ENDIF 1209 1209 !--- … … 1227 1227 starpos = INDEX(NEW_str(1:len_str),'*') 1228 1228 IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & 1229 &.AND.(tmp_str(1:1) /= "'") ) THEN1229 .AND.(tmp_str(1:1) /= "'") ) THEN 1230 1230 !----- 1231 1231 IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN 1232 1232 CALL ipslerr (3,'getin_decrypt', & 1233 &'We can not have a compressed field of values', &1234 &'in a vector notation (TARGET__n).', &1235 &'The key at fault : '//TRIM(key_str))1233 'We can not have a compressed field of values', & 1234 'in a vector notation (TARGET__n).', & 1235 'The key at fault : '//TRIM(key_str)) 1236 1236 ENDIF 1237 1237 !- … … 1245 1245 IF (blk > 1) THEN 1246 1246 CALL ipslerr (2,'getin_decrypt', & 1247 &'This is a strange behavior','you could report',' ')1247 'This is a strange behavior','you could report',' ') 1248 1248 ENDIF 1249 1249 WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) … … 1259 1259 !- 1260 1260 IF ( (blk <= 1) & 1261 &.OR.(tmp_str(1:1) == '"') &1262 &.OR.(tmp_str(1:1) == "'") ) THEN1261 .OR.(tmp_str(1:1) == '"') & 1262 .OR.(tmp_str(1:1) == "'") ) THEN 1263 1263 !- 1264 1264 IF (nb_lastkey == 0) THEN … … 1273 1273 WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 1274 1274 targetlist(nb_lines) = & 1275 &key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt1275 key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1276 1276 last_key = & 1277 &key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt1277 key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1278 1278 nb_lastkey = nb_lastkey+1 1279 1279 ENDIF … … 1291 1291 IF (INDEX(TRIM(key_str),'__') > 0) THEN 1292 1292 CALL ipslerr (3,'getin_decrypt', & 1293 &'We have found a mixed vector notation (TARGET__n).', &1294 &'The key at fault : '//TRIM(key_str),' ')1293 'We have found a mixed vector notation (TARGET__n).', & 1294 'The key at fault : '//TRIM(key_str),' ') 1295 1295 ENDIF 1296 1296 !- … … 1305 1305 fichier(nb_lines) = tmp_str(1:blk) 1306 1306 new_key = & 1307 &key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt1307 key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1308 1308 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1309 1309 fromfile(nb_lines) = current … … 1325 1325 fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) 1326 1326 new_key = & 1327 &key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt1327 key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1328 1328 targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) 1329 1329 fromfile(nb_lines) = current 1330 1330 !- 1331 1331 last_key = & 1332 &key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt1332 key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt 1333 1333 nb_lastkey = nbve 1334 1334 !- … … 1364 1364 WRITE(*,*) 'COUNT : ',n_k 1365 1365 WRITE(*,*) & 1366 &'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))1366 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) 1367 1367 WRITE(*,*) & 1368 &'getin_checkcohe : The following values were encoutered :'1368 'getin_checkcohe : The following values were encoutered :' 1369 1369 WRITE(*,*) & 1370 &' ',TRIM(targetlist(line)),' == ',fichier(line)1370 ' ',TRIM(targetlist(line)),' == ',fichier(line) 1371 1371 WRITE(*,*) & 1372 &' ',TRIM(targetlist(k)),' == ',fichier(k)1372 ' ',TRIM(targetlist(k)),' == ',fichier(k) 1373 1373 WRITE(*,*) & 1374 &'getin_checkcohe : We will keep only the last value'1374 'getin_checkcohe : We will keep only the last value' 1375 1375 targetlist(line) = ' ' 1376 1376 ENDIF … … 1434 1434 IF (ier /= 0) THEN 1435 1435 CALL ipslerr (3,'getin_allockeys', & 1436 &'Can not allocate key_tab', &1437 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1436 'Can not allocate key_tab', & 1437 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1438 1438 ENDIF 1439 1439 nb_keys = 0 … … 1450 1450 IF (ier /= 0) THEN 1451 1451 CALL ipslerr (3,'getin_allockeys', & 1452 &'Can not allocate tmp_key_tab', &1453 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1452 'Can not allocate tmp_key_tab', & 1453 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1454 1454 ENDIF 1455 1455 WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs … … 1459 1459 IF (ier /= 0) THEN 1460 1460 CALL ipslerr (3,'getin_allockeys', & 1461 &'Can not allocate key_tab', &1462 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1461 'Can not allocate key_tab', & 1462 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1463 1463 ENDIF 1464 1464 key_tab(:)%keycompress = -1 … … 1495 1495 WRITE (UNIT=c_tmp,FMT=*) memslabs 1496 1496 CALL ipslerr (3,'getin_allocmem', & 1497 &'Unable to allocate db-memory', &1498 &'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1497 'Unable to allocate db-memory', & 1498 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1499 1499 ENDIF 1500 1500 i_memsize=memslabs … … 1504 1504 WRITE (UNIT=c_tmp,FMT=*) i_memsize 1505 1505 CALL ipslerr (3,'getin_allocmem', & 1506 &'Unable to allocate tmp_int', &1507 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1506 'Unable to allocate tmp_int', & 1507 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1508 1508 ENDIF 1509 1509 tmp_int(1:i_memsize) = i_mem(1:i_memsize) … … 1513 1513 WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) 1514 1514 CALL ipslerr (3,'getin_allocmem', & 1515 &'Unable to re-allocate db-memory', &1516 &'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1515 'Unable to re-allocate db-memory', & 1516 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1517 1517 ENDIF 1518 1518 i_mem(1:i_memsize) = tmp_int(1:i_memsize) … … 1526 1526 WRITE (UNIT=c_tmp,FMT=*) memslabs 1527 1527 CALL ipslerr (3,'getin_allocmem', & 1528 &'Unable to allocate db-memory', &1529 &'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1528 'Unable to allocate db-memory', & 1529 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1530 1530 ENDIF 1531 1531 r_memsize = memslabs … … 1535 1535 WRITE (UNIT=c_tmp,FMT=*) r_memsize 1536 1536 CALL ipslerr (3,'getin_allocmem', & 1537 &'Unable to allocate tmp_real', &1538 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1537 'Unable to allocate tmp_real', & 1538 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1539 1539 ENDIF 1540 1540 tmp_real(1:r_memsize) = r_mem(1:r_memsize) … … 1544 1544 WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) 1545 1545 CALL ipslerr (3,'getin_allocmem', & 1546 &'Unable to re-allocate db-memory', &1547 &'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1546 'Unable to re-allocate db-memory', & 1547 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1548 1548 ENDIF 1549 1549 r_mem(1:r_memsize) = tmp_real(1:r_memsize) … … 1557 1557 WRITE (UNIT=c_tmp,FMT=*) memslabs 1558 1558 CALL ipslerr (3,'getin_allocmem', & 1559 &'Unable to allocate db-memory', &1560 &'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1559 'Unable to allocate db-memory', & 1560 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1561 1561 ENDIF 1562 1562 c_memsize = memslabs … … 1566 1566 WRITE (UNIT=c_tmp,FMT=*) c_memsize 1567 1567 CALL ipslerr (3,'getin_allocmem', & 1568 &'Unable to allocate tmp_char', &1569 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1568 'Unable to allocate tmp_char', & 1569 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1570 1570 ENDIF 1571 1571 tmp_char(1:c_memsize) = c_mem(1:c_memsize) … … 1575 1575 WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) 1576 1576 CALL ipslerr (3,'getin_allocmem', & 1577 &'Unable to re-allocate db-memory', &1578 &'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1577 'Unable to re-allocate db-memory', & 1578 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1579 1579 ENDIF 1580 1580 c_mem(1:c_memsize) = tmp_char(1:c_memsize) … … 1588 1588 WRITE (UNIT=c_tmp,FMT=*) memslabs 1589 1589 CALL ipslerr (3,'getin_allocmem', & 1590 &'Unable to allocate db-memory', &1591 &'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1590 'Unable to allocate db-memory', & 1591 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1592 1592 ENDIF 1593 1593 l_memsize = memslabs … … 1597 1597 WRITE (UNIT=c_tmp,FMT=*) l_memsize 1598 1598 CALL ipslerr (3,'getin_allocmem', & 1599 &'Unable to allocate tmp_logic', &1600 &'to size '//TRIM(ADJUSTL(c_tmp)),' ')1599 'Unable to allocate tmp_logic', & 1600 'to size '//TRIM(ADJUSTL(c_tmp)),' ') 1601 1601 ENDIF 1602 1602 tmp_logic(1:l_memsize) = l_mem(1:l_memsize) … … 1606 1606 WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) 1607 1607 CALL ipslerr (3,'getin_allocmem', & 1608 &'Unable to re-allocate db-memory', &1609 &'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')1608 'Unable to re-allocate db-memory', & 1609 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') 1610 1610 ENDIF 1611 1611 l_mem(1:l_memsize) = tmp_logic(1:l_memsize) … … 1640 1640 IF (ier /= 0) THEN 1641 1641 CALL ipslerr (3,'getin_alloctxt', & 1642 &'Can not allocate fichier', &1643 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1642 'Can not allocate fichier', & 1643 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1644 1644 ENDIF 1645 1645 !--- … … 1647 1647 IF (ier /= 0) THEN 1648 1648 CALL ipslerr (3,'getin_alloctxt', & 1649 &'Can not allocate targetlist', &1650 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1649 'Can not allocate targetlist', & 1650 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1651 1651 ENDIF 1652 1652 !--- … … 1654 1654 IF (ier /= 0) THEN 1655 1655 CALL ipslerr (3,'getin_alloctxt', & 1656 &'Can not allocate fromfile', &1657 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1656 'Can not allocate fromfile', & 1657 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1658 1658 ENDIF 1659 1659 !--- … … 1661 1661 IF (ier /= 0) THEN 1662 1662 CALL ipslerr (3,'getin_alloctxt', & 1663 &'Can not allocate compline', &1664 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1663 'Can not allocate compline', & 1664 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1665 1665 ENDIF 1666 1666 !--- … … 1677 1677 IF (ier /= 0) THEN 1678 1678 CALL ipslerr (3,'getin_alloctxt', & 1679 &'Can not allocate tmp_fic', &1680 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1679 'Can not allocate tmp_fic', & 1680 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1681 1681 ENDIF 1682 1682 tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) … … 1685 1685 IF (ier /= 0) THEN 1686 1686 CALL ipslerr (3,'getin_alloctxt', & 1687 &'Can not allocate fichier', &1688 &'to size '//TRIM(ADJUSTL(c_tmp2)),' ')1687 'Can not allocate fichier', & 1688 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') 1689 1689 ENDIF 1690 1690 fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) … … 1694 1694 IF (ier /= 0) THEN 1695 1695 CALL ipslerr (3,'getin_alloctxt', & 1696 &'Can not allocate tmp_tgl', &1697 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1696 'Can not allocate tmp_tgl', & 1697 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1698 1698 ENDIF 1699 1699 tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) … … 1702 1702 IF (ier /= 0) THEN 1703 1703 CALL ipslerr (3,'getin_alloctxt', & 1704 &'Can not allocate targetlist', &1705 &'to size '//TRIM(ADJUSTL(c_tmp2)),' ')1704 'Can not allocate targetlist', & 1705 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') 1706 1706 ENDIF 1707 1707 targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) … … 1711 1711 IF (ier /= 0) THEN 1712 1712 CALL ipslerr (3,'getin_alloctxt', & 1713 &'Can not allocate tmp_int', &1714 &'to size '//TRIM(ADJUSTL(c_tmp1)),' ')1713 'Can not allocate tmp_int', & 1714 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') 1715 1715 ENDIF 1716 1716 tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) … … 1719 1719 IF (ier /= 0) THEN 1720 1720 CALL ipslerr (3,'getin_alloctxt', & 1721 &'Can not allocate fromfile', &1722 &'to size '//TRIM(ADJUSTL(c_tmp2)),' ')1721 'Can not allocate fromfile', & 1722 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') 1723 1723 ENDIF 1724 1724 fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) … … 1729 1729 IF (ier /= 0) THEN 1730 1730 CALL ipslerr (3,'getin_alloctxt', & 1731 &'Can not allocate compline', &1732 &'to size '//TRIM(ADJUSTL(c_tmp2)),' ')1731 'Can not allocate compline', & 1732 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') 1733 1733 ENDIF 1734 1734 compline(1:i_txtsize) = tmp_int(1:i_txtsize) … … 1765 1765 IF (check) THEN 1766 1766 WRITE(*,*) & 1767 &'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if1767 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if 1768 1768 WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys 1769 1769 ENDIF … … 1792 1792 CASE(1) 1793 1793 WRITE(22,*) '# Values of ', & 1794 &TRIM(key_tab(ikey)%keystr),' comes from the run.def.'1794 TRIM(key_tab(ikey)%keystr),' comes from the run.def.' 1795 1795 CASE(2) 1796 1796 WRITE(22,*) '# Values of ', & 1797 &TRIM(key_tab(ikey)%keystr),' are all defaults.'1797 TRIM(key_tab(ikey)%keystr),' are all defaults.' 1798 1798 CASE(3) 1799 1799 WRITE(22,*) '# Values of ', & 1800 &TRIM(key_tab(ikey)%keystr), &1801 &' are a mix of run.def and defaults.'1800 TRIM(key_tab(ikey)%keystr), & 1801 ' are a mix of run.def and defaults.' 1802 1802 CASE DEFAULT 1803 1803 WRITE(22,*) '# Dont know from where the value of ', & 1804 &TRIM(key_tab(ikey)%keystr),' comes.'1804 TRIM(key_tab(ikey)%keystr),' comes.' 1805 1805 END SELECT 1806 1806 WRITE(22,*) '#' … … 1812 1812 IF (key_tab(ikey)%keycompress < 0) THEN 1813 1813 WRITE(22,*) & 1814 &TRIM(key_tab(ikey)%keystr), &1815 &' = ',i_mem(key_tab(ikey)%keymemstart)1814 TRIM(key_tab(ikey)%keystr), & 1815 ' = ',i_mem(key_tab(ikey)%keymemstart) 1816 1816 ELSE 1817 1817 WRITE(22,*) & 1818 &TRIM(key_tab(ikey)%keystr), &1819 &' = ',key_tab(ikey)%keycompress, &1820 &' * ',i_mem(key_tab(ikey)%keymemstart)1818 TRIM(key_tab(ikey)%keystr), & 1819 ' = ',key_tab(ikey)%keycompress, & 1820 ' * ',i_mem(key_tab(ikey)%keymemstart) 1821 1821 ENDIF 1822 1822 ELSE … … 1824 1824 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1825 1825 WRITE(22,*) & 1826 &TRIM(key_tab(ikey)%keystr), &1827 &'__',TRIM(ADJUSTL(c_tmp)), &1828 &' = ',i_mem(key_tab(ikey)%keymemstart+iv)1826 TRIM(key_tab(ikey)%keystr), & 1827 '__',TRIM(ADJUSTL(c_tmp)), & 1828 ' = ',i_mem(key_tab(ikey)%keymemstart+iv) 1829 1829 ENDDO 1830 1830 ENDIF … … 1833 1833 IF (key_tab(ikey)%keycompress < 0) THEN 1834 1834 WRITE(22,*) & 1835 &TRIM(key_tab(ikey)%keystr), &1836 &' = ',r_mem(key_tab(ikey)%keymemstart)1835 TRIM(key_tab(ikey)%keystr), & 1836 ' = ',r_mem(key_tab(ikey)%keymemstart) 1837 1837 ELSE 1838 1838 WRITE(22,*) & 1839 &TRIM(key_tab(ikey)%keystr), &1840 &' = ',key_tab(ikey)%keycompress, &1841 &' * ',r_mem(key_tab(ikey)%keymemstart)1839 TRIM(key_tab(ikey)%keystr), & 1840 ' = ',key_tab(ikey)%keycompress, & 1841 ' * ',r_mem(key_tab(ikey)%keymemstart) 1842 1842 ENDIF 1843 1843 ELSE … … 1845 1845 WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 1846 1846 WRITE(22,*) & 1847 &TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &1848 &' = ',r_mem(key_tab(ikey)%keymemstart+iv)1847 TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & 1848 ' = ',r_mem(key_tab(ikey)%keymemstart+iv) 1849 1849 ENDDO 1850 1850 ENDIF … … 1853 1853 tmp_str = c_mem(key_tab(ikey)%keymemstart) 1854 1854 WRITE(22,*) TRIM(key_tab(ikey)%keystr), & 1855 &' = ',TRIM(tmp_str)1855 ' = ',TRIM(tmp_str) 1856 1856 ELSE 1857 1857 DO iv=0,key_tab(ikey)%keymemlen-1 … … 1859 1859 tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) 1860 1860 WRITE(22,*) & 1861 &TRIM(key_tab(ikey)%keystr), &1862 &'__',TRIM(ADJUSTL(c_tmp)), &1863 &' = ',TRIM(tmp_str)1861 TRIM(key_tab(ikey)%keystr), & 1862 '__',TRIM(ADJUSTL(c_tmp)), & 1863 ' = ',TRIM(tmp_str) 1864 1864 ENDDO 1865 1865 ENDIF … … 1876 1876 IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN 1877 1877 WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & 1878 &TRIM(ADJUSTL(c_tmp)),' = TRUE '1878 TRIM(ADJUSTL(c_tmp)),' = TRUE ' 1879 1879 ELSE 1880 1880 WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & 1881 &TRIM(ADJUSTL(c_tmp)),' = FALSE '1881 TRIM(ADJUSTL(c_tmp)),' = FALSE ' 1882 1882 ENDIF 1883 1883 ENDDO … … 1885 1885 CASE DEFAULT 1886 1886 CALL ipslerr (3,'getin_dump', & 1887 &'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &1888 &' ',' ')1887 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & 1888 ' ',' ') 1889 1889 END SELECT 1890 1890 ENDIF … … 1912 1912 k_typ = 0 1913 1913 IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & 1914 &/= 1) THEN1914 /= 1) THEN 1915 1915 CALL ipslerr (3,'get_qtyp', & 1916 &'Invalid number of optional arguments','(/= 1)',' ')1916 'Invalid number of optional arguments','(/= 1)',' ') 1917 1917 ENDIF 1918 1918 !-
Note: See TracChangeset
for help on using the changeset viewer.
