OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
message.F File Reference
#include "implicit_f.inc"
#include "units_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine ancmsg (msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
subroutine mess_extract_format (tmpline, line_size, ncount, id_num, key, key_len)
character *2 function nl ()

Function/Subroutine Documentation

◆ ancmsg()

subroutine ancmsg ( integer msgid,
integer msgtype,
integer anmode,
integer, optional i1,
integer, optional i2,
integer, optional i3,
integer, optional i4,
integer, optional i5,
integer, optional i6,
integer, optional i7,
integer, optional i8,
integer, optional i9,
integer, optional i10,
integer, optional i11,
integer, optional i12,
integer, optional i13,
integer, optional i14,
integer, optional i15,
integer, optional i16,
integer, optional i17,
integer, optional i18,
integer, optional i19,
integer, optional i20,
optional r1,
optional r2,
optional r3,
optional r4,
optional r5,
optional r6,
optional r7,
optional r8,
optional r9,
character(*), optional c1,
character(*), optional c2,
character(*), optional c3,
character(*), optional c4,
character(*), optional c5,
character(*), optional c6,
character(*), optional c7,
character(*), optional c8,
character(*), optional c9,
integer, optional prmode )

Definition at line 879 of file message.F.

889c . PRMODE,IOPTION, IOPTION_TYPE)
890 USE message_mod2
891C-----------------------------------------------
892C Usage sample :
893C USE MESSAGE_MOD
894C ...
895C CALL ANCMSG(MSGID=9999,ANMODE=ANINFO_BLIND,
896C . I1=28,C1='TIME STEP COMPUTATION',C2='SHELL')
897C ... ... ... ... ...
898C ANMODE=ANINFO/ANINFO_BLIND
899C ANINFO write both title and description in standard output and listing
900C ANINFO_BLIND do not write description in standard output
901C ... ... ... ... ...
902C It is recommended to use ANINFO for sensitive messages.
903C ... ... ... ... ...
904C PRMODE=MSG_CUMU/MSG_PRINT
905C MSG_CUMU cumul information in a scratch file
906C MSG_PRINT print compact message from the scratch file
907C ... ... ... ... ...
908C starter_message_description.txt extract :
909C ...
910C /MESSAGE/9999/TITLE
911C \n ** ERROR DURING %s\n
912C
913C /MESSAGE/9999/DESCRIPTION
914C DURING COMPUTATION IT APPEARS THAT
915C %s ELEMENT ID=%d HAD A TIME STEP EQUAL TO ZERO
916C ENGINE WILL STOP
917C-----------------------------------------------
918C I m p l i c i t T y p e s
919C-----------------------------------------------
920#include "implicit_f.inc"
921C-----------------------------------------------
922C C o m m o n B l o c k s
923C-----------------------------------------------
924C-----------------------------------------------
925C D u m m y A r g u m e n t s
926C-----------------------------------------------
927 INTEGER MSGID,ANMODE,MSGTYPE,PRMODE
928c INTEGER MSGID,ANMODE,MSGTYPE,PRMODE,IOPTION,IOPTION_TYPE
929 integer
930 . i1,i2,i3,i4,i5,
931 . i6,i7,i8,i9,i10,
932 . i11,i12,i13,i14,i15,
933 . i16,i17,i18,i19,i20
934 my_real
935 . r1,r2,r3,r4,
936 . r5,r6,r7,r8,r9
937 CHARACTER(*)
938 . C1,C2,C3,C4,
939 . C5,C6,C7,C8,C9
940 OPTIONAL ::
941 . i1,i2,i3,i4,i5,
942 . i6,i7,i8,i9,i10,
943 . i11,i12,i13,i14,i15,
944 . i16,i17,i18,i19,i20,
945 . r1,r2,r3,r4,
946 . r5,r6,r7,r8,r9,
947 . c1,c2,c3,c4,
948 . c5,c6,c7,c8,c9,
949 . prmode
950c . PRMODE,IOPTION,IOPTION_TYPE
951C-----------------------------------------------
952C C o m m o n B l o c k s
953C-----------------------------------------------
954#include "units_c.inc"
955C-----------------------------------------------
956C L o c a l V a r i a b l e s
957C-----------------------------------------------
958 INTEGER IBUF(20)
959 my_real rbuf(10)
960 CHARACTER(LEN=NCHARLINE) CBUF(10)
961C
962 CHARACTER(LEN=NCHARLINE):: TMPLINE,MYFMT,TMPBUF
963 CHARACTER(LEN=NCHARLINE):: TMPOUT,TMPIN,TMPIN2,TMPIN3
964 CHARACTER*20 CMSGTYPE
965 CHARACTER*15 CTYPE
966 INTEGER ITYPE,ILINE,I,I0,J,J0,SBUFMSG(2),IFILE,IOLD,
967 * INDXI,INDXR,INDXC,INDXD,INDXTMPOUT,BUFLEN,
968 * STMP,IEXIST,IEND,MSGID_R,CPT,NBREPET,NBREPET_0,
969 * INT_TMP,ITMP,INDXI_INC,INDXR_INC,INDXC_INC,INDXD_INC,
970 * NB_IBUF,NB_RBUF,NB_CBUF,MODE, WORK(70000),K,
971 * NB_MESSAGES,ITAG,NO_PRINT,ISAV
972 my_real real_tmp
973 INTEGER NCOUNT,ID_NUM,KEY_LEN
974 CHARACTER(LEN=NCHARLINE) KEY, BUFMSG(2,100),BUFFMT(2,100),CHAR_TMP
975 CHARACTER*2304 OPTION_NAME_DYNA,DYNA_TITLE
976 INTEGER S_OPTION_NAME_DYNA,SDYNA_TITLE,DYNA_ID
977C
978 INTEGER, DIMENSION(:), ALLOCATABLE :: TMP_INTEGER
979 my_real, DIMENSION(:), ALLOCATABLE :: tmp_real
980 CHARACTER(LEN=NCHARLINE), DIMENSION(:), ALLOCATABLE :: TMP_CHAR
981 CHARACTER(LEN=NCHARLINE), DIMENSION(:), ALLOCATABLE :: TMP_I
982 INTEGER, DIMENSION(:,:), ALLOCATABLE :: ITRI
983 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX,MES_DOUBLE
984C-----------------------------------------------
985 CHARACTER*2 NL
986 CHARACTER*1, PARAMETER :: BACKSLASH = char(92)
987 EXTERNAL nl
988C-----------------------------------------------
989
990 nbrepet = 0
991C
992 IF(PRESENT(prmode))THEN
993
994 ibuf=0
995 rbuf=zero
996 cbuf=' '
997C
998 indxi=0
999 indxr=0
1000 indxc=0
1001 indxd=0
1002C
1003 tmpout=' '
1004 indxtmpout=0
1005 tmpbuf=' '
1006C
1007 nb_ibuf = 0
1008 nb_rbuf = 0
1009 nb_cbuf = 0
1010C
1011
1012C ----------------------------
1013C Argument presence checking
1014C ----------------------------
1015 IF (PRESENT(i1)) THEN
1016 ibuf(1)=i1
1017 nb_ibuf = nb_ibuf + 1
1018 IF (PRESENT(i2)) THEN
1019 ibuf(2)=i2
1020 nb_ibuf = nb_ibuf + 1
1021 IF (PRESENT(i3)) THEN
1022 ibuf(3)=i3
1023 nb_ibuf = nb_ibuf + 1
1024 IF (PRESENT(i4)) THEN
1025 ibuf(4)=i4
1026 nb_ibuf = nb_ibuf + 1
1027 IF (PRESENT(i5)) THEN
1028 ibuf(5)=i5
1029 nb_ibuf = nb_ibuf + 1
1030 IF (PRESENT(i6)) THEN
1031 ibuf(6)=i6
1032 nb_ibuf = nb_ibuf + 1
1033 IF (PRESENT(i7)) THEN
1034 ibuf(7)=i7
1035 nb_ibuf = nb_ibuf + 1
1036 IF (PRESENT(i8)) THEN
1037 ibuf(8)=i8
1038 nb_ibuf = nb_ibuf + 1
1039 IF (PRESENT(i9)) THEN
1040 ibuf(9)=i9
1041 nb_ibuf = nb_ibuf + 1
1042 IF (PRESENT(i10)) THEN
1043 ibuf(10)=i10
1044 nb_ibuf = nb_ibuf + 1
1045 IF (PRESENT(i11)) THEN
1046 ibuf(11)=i11
1047 nb_ibuf = nb_ibuf + 1
1048 IF (PRESENT(i12)) THEN
1049 ibuf(12)=i12
1050 nb_ibuf = nb_ibuf + 1
1051 IF (PRESENT(i13)) THEN
1052 ibuf(13)=i13
1053 nb_ibuf = nb_ibuf + 1
1054 IF (PRESENT(i14)) THEN
1055 ibuf(14)=i14
1056 nb_ibuf = nb_ibuf + 1
1057 IF (PRESENT(i15)) THEN
1058 ibuf(15)=i15
1059 nb_ibuf = nb_ibuf + 1
1060 IF (PRESENT(i16)) THEN
1061 ibuf(16)=i16
1062 nb_ibuf = nb_ibuf + 1
1063 IF (PRESENT(i17)) THEN
1064 ibuf(17)=i17
1065 nb_ibuf = nb_ibuf + 1
1066 IF (PRESENT(i18)) THEN
1067 ibuf(18)=i18
1068 nb_ibuf = nb_ibuf + 1
1069 IF (PRESENT(i19)) THEN
1070 ibuf(19)=i19
1071 nb_ibuf = nb_ibuf + 1
1072 IF (PRESENT(i20)) THEN
1073 ibuf(20)=i20
1074 nb_ibuf = nb_ibuf + 1
1075 END IF
1076 END IF
1077 END IF
1078 END IF
1079 END IF
1080 END IF
1081 END IF
1082 END IF
1083 END IF
1084 END IF
1085 END IF
1086 END IF
1087 END IF
1088 END IF
1089 END IF
1090 END IF
1091 END IF
1092 END IF
1093 END IF
1094 END IF
1095C
1096 IF (PRESENT(r1)) THEN
1097 rbuf(1)=r1
1098 nb_rbuf = nb_rbuf + 1
1099 IF (PRESENT(r2)) THEN
1100 rbuf(2)=r2
1101 nb_rbuf = nb_rbuf + 1
1102 IF (PRESENT(r3)) THEN
1103 rbuf(3)=r3
1104 nb_rbuf = nb_rbuf + 1
1105 IF (PRESENT(r4)) THEN
1106 rbuf(4)=r4
1107 nb_rbuf = nb_rbuf + 1
1108 IF (PRESENT(r5)) THEN
1109 rbuf(5)=r5
1110 nb_rbuf = nb_rbuf + 1
1111 IF (PRESENT(r6)) THEN
1112 rbuf(6)=r6
1113 nb_rbuf = nb_rbuf + 1
1114 IF (PRESENT(r7)) THEN
1115 rbuf(7)=r7
1116 nb_rbuf = nb_rbuf + 1
1117 IF (PRESENT(r8)) THEN
1118 rbuf(8)=r8
1119 nb_rbuf = nb_rbuf + 1
1120 IF (PRESENT(r9)) THEN
1121 rbuf(9)=r9
1122 nb_rbuf = nb_rbuf + 1
1123 END IF
1124 END IF
1125 END IF
1126 END IF
1127 END IF
1128 END IF
1129 END IF
1130 END IF
1131 END IF
1132C
1133 IF (PRESENT(c1)) THEN
1134 cbuf(1)=c1
1135 nb_cbuf = nb_cbuf + 1
1136 IF (PRESENT(c2)) THEN
1137 cbuf(2)=c2
1138 nb_cbuf = nb_cbuf + 1
1139 IF (PRESENT(c3)) THEN
1140 cbuf(3)=c3
1141 nb_cbuf = nb_cbuf + 1
1142 IF (PRESENT(c4)) THEN
1143 cbuf(4)=c4
1144 nb_cbuf = nb_cbuf + 1
1145 IF (PRESENT(c5)) THEN
1146 cbuf(5)=c5
1147 nb_cbuf = nb_cbuf + 1
1148 IF (PRESENT(c6)) THEN
1149 cbuf(6)=c6
1150 nb_cbuf = nb_cbuf + 1
1151 IF (PRESENT(c7)) THEN
1152 cbuf(7)=c7
1153 nb_cbuf = nb_cbuf + 1
1154 IF (PRESENT(c8)) THEN
1155 cbuf(8)=c8
1156 nb_cbuf = nb_cbuf + 1
1157 IF (PRESENT(c9)) THEN
1158 cbuf(9)=c9
1159 nb_cbuf = nb_cbuf + 1
1160 END IF
1161 END IF
1162 END IF
1163 END IF
1164 END IF
1165 END IF
1166 END IF
1167 END IF
1168 END IF
1169
1170
1171 IF (prmode == 0) THEN ! PRMODE=MSG_CUMU
1172c
1173C -------------------------
1174C Message is parsed
1175C -------------------------
1176C The results of %d %f %s
1177C are stored in RES_MES FILE
1178C -------------------------
1179
1180
1181 iexist=0
1182 DO itype=1,smsgtype
1183 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1184 iexist=1
1185 END IF
1186 END DO
1187 myfmt='(A,I10,X)'
1188 WRITE(res_mes,myfmt) 'ID=',msgid
1189C
1190 itype = 4
1191 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1192 DO iline=1,messages(itype,msgid)%SMESSAGE
1193 IF (iline>1) ctype=''
1194 tmpout=' '
1195 tmpbuf=' '
1196 IF (messages(itype,msgid)%SMESSAGE/=0) THEN
1197 tmpline=messages(itype,msgid)%MESSAGE(iline)
1198 buflen=0
1199 i=2
1200 iold=1
1201 DO WHILE (i+1<=len_trim(tmpline))
1202 indxtmpout=0
1203 IF (tmpline(i:i)=='%') THEN
1204 i=i+1
1205 IF (tmpline(i:i)=='d') THEN ! %d (integer) replaced with its value
1206 i=i+1
1207 iold=i
1208 myfmt='(I10,X)'
1209 IF (indxi<=20) indxi=indxi+1
1210 WRITE(tmpbuf,myfmt)ibuf(indxi)
1211 tmpbuf=adjustl(tmpbuf)
1212 buflen=len_trim(tmpbuf)+1
1213
1214 ELSE IF (tmpline(i:i)=='f') THEN ! %f (float) replaced with its value
1215 i=i+1
1216 iold=i
1217 myfmt='(1PG20.13,X)'
1218 IF (indxr<10) indxr=indxr+1
1219 WRITE(tmpbuf,myfmt)rbuf(indxr)
1220 tmpbuf=adjustl(tmpbuf)
1221 buflen=len_trim(tmpbuf)+1
1222
1223 ELSE IF (tmpline(i:i)=='s') THEN ! %s (string) replaced with its value
1224 i=i+1
1225 iold=i
1226 myfmt='(A),X'
1227 IF (indxc<10) indxc=indxc+1
1228 WRITE(tmpbuf,myfmt)cbuf(indxc)
1229 tmpbuf=adjustl(tmpbuf)
1230 buflen=len_trim(tmpbuf)+1
1231
1232 ELSEIF (tmpline(i:i)=='i') THEN ! New format %ixxx be computed - for test add fmt
1233 isav=i
1234 i=i+1
1235 IF (dyna_message == 1) THEN ! Treatment ignored when DYNA_MESSAGE=0 / Native Rd Deck
1236 CALL mess_extract_format(tmpline(i:ncharline),len_trim(tmpline(i:ncharline)),ncount,id_num,key,key_len) ! format is %iXX="/KEY" XX=1-11
1237 i=i+ncount
1238 option_name_dyna=' '
1239 s_option_name_dyna=1
1240
1241 CALL cpp_find_dyna_mess(key,key_len,ibuf(id_num),option_name_dyna,
1242 * s_option_name_dyna,isav,dyna_title,sdyna_title)
1243
1244 myfmt='(A)'
1245 WRITE(tmpbuf,myfmt) option_name_dyna(1:s_option_name_dyna)
1246 tmpbuf=adjustl(tmpbuf)
1247 buflen=len_trim(tmpbuf)+1
1248 END IF
1249 END IF
1250 ELSE
1251 i=i+1
1252 END IF
1253 IF (buflen>0) THEN
1254 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
1255 indxtmpout=indxtmpout+buflen
1256 buflen=0
1257 END IF
1258 IF (indxtmpout>0) THEN
1259 WRITE(res_mes,'(A)')tmpout(1:indxtmpout)
1260 END IF
1261 END DO
1262 END IF
1263 END DO
1264 END IF
1265
1266 ELSE ! PRMODE=MSG_PRINT
1267C print compacted message from tmp file
1268c
1269C
1270 OPEN (unit=res_tmp,status='SCRATCH',form='FORMATTED')
1271 rewind(res_mes)
1272 iexist=0
1273C
1274 DO itype=1,smsgtype
1275 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1276 iexist=1
1277 END IF
1278 END DO
1279 nbrepet = 0
1280 iend = 0
1281c---------------------------------
1282c RES_CHECK = 123499
1283c OPEN (UNIT=RES_CHECK,STATUS='UNKNOWN',FORM='FORMATTED',FILE='fort.1')
1284 DO WHILE(iend/=1)
1285 READ(res_mes,'(A)',END=110) tmpin
1286 WRITE(res_check,'(A)') tmpin(1:len_trim(tmpin))
1287 ENDDO
1288110 iend = 1
1289 iend = 0
1290 rewind(res_mes)
1291c---------------------------------
1292 indxi_inc = 0
1293 indxr_inc = 0
1294 indxc_inc = 0
1295 indxd_inc = 0
1296 itype = 4
1297
1298C ------------------------------------------
1299C Message is parsed, format tags are count
1300C ------------------------------------------
1301 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1302 DO iline=1,messages(itype,msgid)%SMESSAGE
1303 IF (messages(itype,msgid)%SMESSAGE/=0) THEN
1304 tmpline=messages(itype,msgid)%MESSAGE(iline)
1305 i=2
1306 iold=1
1307 DO WHILE (i+1<=len_trim(tmpline))
1308 IF (tmpline(i:i)=='%') THEN
1309 i=i+1
1310 IF (tmpline(i:i)=='d') THEN ! %d format
1311 i=i+1
1312 indxi_inc=indxi_inc+1
1313 ELSE IF (tmpline(i:i)=='f') THEN ! %f format
1314 i=i+1
1315 indxr_inc=indxr_inc+1
1316 ELSE IF (tmpline(i:i)=='s') THEN ! %s format
1317 i=i+1
1318 indxc_inc=indxc_inc+1
1319 ELSE IF (tmpline(i:i)=='i') THEN ! %ixxx format
1320 i=i+1
1321 IF(dyna_message == 1) THEN
1322 indxd_inc=indxd_inc+1
1323 ENDIF
1324 ENDIF
1325 ELSE
1326 i=i+1
1327 END IF
1328 END DO
1329 ENDIF
1330 ENDDO
1331 END IF
1332C -----------------------------------
1333C Message file is read
1334C catch all message info from MSGID
1335C -----------------------------------
1336 READ(res_mes,'(A)',END=120) tmpin
1337 DO WHILE(iend/=1)
1338
1339 IF(tmpin(1:3)== 'ID=')THEN
1340 READ(tmpin(4:14),'(I10)') msgid_r
1341 IF (msgid == msgid_r) THEN ! Message ID was found
1342 nbrepet = nbrepet + 1
1343 indxi = indxi + indxi_inc
1344 indxr = indxr + indxr_inc
1345 indxc = indxc + indxc_inc
1346 indxd = indxd + indxd_inc
1347
1348 READ(res_mes,'(A)',END=120) tmpin
1349 DO WHILE(iend/=1 .AND. tmpin(1:3) /= 'ID=') ! skip to next message
1350 READ(res_mes,'(A)',END=120) tmpin
1351 ENDDO
1352 ELSE ! Message ID is different / skip to next message
1353 WRITE(res_tmp,'(A)') tmpin(1:len_trim(tmpin))
1354 READ(res_mes,'(A)',END=120) tmpin
1355 DO WHILE(iend/=1 .AND. tmpin(1:3) /= 'ID=')
1356 WRITE(res_tmp,'(A)') tmpin(1:len_trim(tmpin))
1357 READ(res_mes,'(A)',END=120) tmpin
1358 ENDDO
1359 ENDIF
1360 ENDIF
1361 ENDDO
1362
1363120 iend = 1
1364
1365 rewind(res_mes)
1366c
1367C ------------------------------------------
1368C All counts are done - Allocating buffers
1369C ------------------------------------------
1370 ALLOCATE(itri(indxi_inc,nbrepet))
1371 ALLOCATE(tmp_integer(indxi+nb_ibuf))
1372 ALLOCATE(tmp_real(indxr+nb_rbuf))
1373 ALLOCATE(tmp_char(indxc+nb_cbuf))
1374 ALLOCATE(tmp_i(indxd))
1375c
1376 tmp_integer=0
1377 tmp_real=zero
1378 tmp_i=' '
1379 tmp_char=' '
1380
1381 IF(nbrepet /= 0) THEN
1382 nbrepet_0 = nbrepet
1383 nbrepet = 0
1384 iend = 0
1385 indxi=nb_ibuf
1386 indxr=nb_rbuf
1387 indxc=nb_cbuf
1388 indxd=0
1389 cpt = 0
1390
1391C ----------------------
1392C Re-read message file
1393C ----------------------
1394 DO WHILE(iend/=1)
1395 READ(res_mes,'(A)',END=130) tmpin
1396 IF(tmpin(1:3)== 'ID=')THEN
1397 READ(tmpin(4:14),'(I10)') msgid_r
1398
1399 IF (msgid == msgid_r) THEN ! Look for all messages bellonging to msgid number
1400 nbrepet = nbrepet + 1
1401c
1402 itype = 4
1403 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN ! Parsing the message and their formats
1404 DO iline=1,messages(itype,msgid)%SMESSAGE
1405 IF (messages(itype,msgid)%SMESSAGE/=0) THEN
1406 tmpline=messages(itype,msgid)%MESSAGE(iline)
1407 i=2
1408 iold=1
1409 no_print=0
1410 DO WHILE (i+1<=len_trim(tmpline))
1411 IF (tmpline(i:i)=='%') THEN
1412 i=i+1
1413 IF (tmpline(i:i)=='d') THEN
1414 i=i+1
1415 iold=i
1416 indxi=indxi+1
1417 cpt=cpt+1
1418 READ(res_mes,'(A)',END=130) tmpin
1419 READ(tmpin,'(I10)') int_tmp
1420 tmp_integer(indxi) = int_tmp
1421 itri(cpt,nbrepet) = int_tmp
1422 IF(cpt == indxi_inc) cpt = 0
1423 ELSE IF (tmpline(i:i)=='f') THEN
1424 i=i+1
1425 iold=i
1426 indxr=indxr+1
1427 READ(res_mes,'(A)',END=130) tmpin
1428 READ(tmpin,*) real_tmp
1429 tmp_real(indxr) = real_tmp
1430 ELSE IF (tmpline(i:i)=='s') THEN
1431 i=i+1
1432 iold=i
1433 indxc=indxc+1
1434 READ(res_mes,'(A)',END=130) tmpin
1435 READ(tmpin,'(A)') char_tmp
1436 tmp_char(indxc) = char_tmp
1437 ELSE IF (tmpline(i:i)=='i') THEN
1438 i=i+1
1439 IF(dyna_message == 1) THEN
1440 iold=i
1441 indxd=indxd+1
1442 READ(res_mes,'(A)',END=130) tmpin
1443 READ(res_mes,'(A)',END=130) tmpin2
1444 READ(res_mes,'(A)',END=130) tmpin3
1445
1446 char_tmp=tmpin(1:len_trim(tmpin))//nl()//tmpin2(1:len_trim(tmpin2))
1447 * //nl()//tmpin3(1:len_trim(tmpin3))
1448 tmp_i(indxd) = char_tmp
1449 ELSE
1450 no_print=1
1451 ENDIF
1452 ENDIF
1453 ELSE
1454 i=i+1
1455 END IF
1456 END DO
1457 ENDIF
1458 ENDDO
1459 END IF
1460 ENDIF
1461 ENDIF
1462 ENDDO
1463130 iend = 1
1464C
1465 indxi=0
1466 indxr=0
1467 indxc=0
1468 indxd=0
1469 iexist=0
1470 cpt = 0
1471c remove duplicated messages
1472 mode = 0
1473 ALLOCATE(index(2*nbrepet_0*indxi_inc))
1474 IF (nbrepet_0 . ne. 0)THEN
1475 ALLOCATE(mes_double(nbrepet_0))
1476 mes_double(1) = 0
1477 IF (indxi_inc == 0)THEN
1478 mes_double(2:nbrepet_0) = 0
1479 ELSE
1480 mes_double(2:nbrepet_0) = 1
1481 ENDIF
1482 ELSE
1483 ALLOCATE(mes_double(1))
1484 mes_double(1) = 0
1485 ENDIF
1486c
1487 DO j=1,nbrepet_0
1488 index(j) = j
1489 ENDDO
1490 CALL my_orders( mode, work, itri,index,nbrepet_0,indxi_inc)
1491 IF (nbrepet_0 /= 0) mes_double(index(1)) = 0
1492 DO j=2,nbrepet_0
1493 itag = 0
1494 DO k=1,indxi_inc
1495 IF(itri(k,index(j)) /=
1496 . itri(k,index(j-1)))THEN
1497 itag = itag + 1
1498 ENDIF
1499 ENDDO
1500 IF (itag /= 0) mes_double(index(j)) = 0
1501 ENDDO
1502 nb_messages = 0
1503 DO j=1,nbrepet_0
1504 IF(mes_double(index(j)) == 0) nb_messages = nb_messages + 1
1505 ENDDO
1506
1507c-----------------------------------------------------------
1508c MESSAGE SUMMARY
1509c-----------------------------------------------------------
1510c
1511 myfmt='(A,X,A)'
1512 IF(msgtype == 0) THEN
1513 WRITE(res_check,myfmt) 'M_OPTION=',err_category(1:len_trim(err_category))
1514 ELSEIF(msgtype == 1) THEN
1515 WRITE(res_check,myfmt) 'W_OPTION=',err_category(1:len_trim(err_category))
1516 ELSEIF(msgtype == 2) THEN
1517 WRITE(res_check,myfmt) 'E_OPTION=',err_category(1:len_trim(err_category))
1518 ENDIF
1519 myfmt='(A,I10,X)'
1520 WRITE(res_check,myfmt) 'OPTION_TYPE=',0
1521 IF(PRESENT(i1))THEN
1522 WRITE(res_check,myfmt) 'OPTION_ID=',i1
1523 ELSE
1524 WRITE(res_check,myfmt) 'OPTION_ID=',0
1525 ENDIF
1526 myfmt='(A,X,A)'
1527 IF(PRESENT(c1))THEN
1528 WRITE(res_check,myfmt) 'TITLE=',c1(1:len_trim(c1))
1529 ELSE
1530 WRITE(res_check,myfmt) 'TITLE=',''
1531 ENDIF
1532 myfmt='(A,I10,X)'
1533 WRITE(res_check,myfmt) 'ID_MES=',msgid
1534 WRITE(res_check,myfmt) 'NB_REPET=',nbrepet
1535C
1536 cmsgtype=' '
1537 IF (msgtype==0) THEN
1538 cmsgtype='MESSAGE'
1539 imsg=imsg+1
1540 ELSE IF (msgtype==1) THEN
1541 cmsgtype='WARNING'
1542 iwarn=iwarn+1
1543 ELSE IF (msgtype==2) THEN
1544 cmsgtype='ERROR'
1545 ierr=ierr+1
1546 END IF
1547 iexist=0
1548 DO itype=1,smsgtype
1549 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1550 iexist=1
1551 END IF
1552 END DO
1553 IF (iexist == 0) THEN
1554 WRITE(istdo,'(A,A,A,I6)')'CALL TO UNEXISTING ',
1555 . cmsgtype(1:len_trim(cmsgtype)),
1556 . ' ID = ',
1557 . msgid
1558 IF (iout/=0) THEN
1559 WRITE(iout,'(A,A,A,I6)')'CALL TO UNEXISTING ',
1560 . cmsgtype(1:len_trim(cmsgtype)),
1561 . ' ID = ',
1562 . msgid
1563 END IF
1564 RETURN
1565 END IF
1566 IF (anmode/=aninfo_blind_2) THEN
1567 WRITE(istdo,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))
1568 * //' ID : ',msgid
1569 END IF
1570 IF (istdo/=iout) THEN
1571 IF (iout/=0) THEN
1572 WRITE(iout,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))
1573 * //' ID : ',msgid
1574 ELSE
1575 WRITE(istdo,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))
1576 * //' ID : ',msgid
1577 END IF
1578 END IF
1579c
1580 DO itype=1,smsgtype
1581 IF (itype==1) THEN
1582 ctype=''
1583 ELSE IF (itype==2) THEN
1584C WRITE(CTYPE,'(A,/)')"DESCRIPTION : "
1585 ctype='DESCRIPTION : '
1586 ELSE IF (itype==3) THEN
1587 ctype='SOLUTION : '
1588 ELSE IF (itype==4) THEN
1589 ctype=''
1590 END IF
1591 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1592 IF (itype == 4)THEN
1593 nbrepet = nbrepet_0
1594 ELSE
1595 nbrepet = 1
1596 ENDIF
1597 DO cpt = 1,nbrepet
1598 DO iline=1,messages(itype,msgid)%SMESSAGE
1599 IF (iline>1) ctype=''
1600 tmpout=' '
1601 tmpbuf=' '
1602 IF (messages(itype,msgid)%SMESSAGE/=0 ) THEN
1603 tmpline=messages(itype,msgid)%MESSAGE(iline)
1604 buflen=0
1605 indxtmpout=0
1606 i=1
1607 iold=1
1608 no_print = 0
1609 DO WHILE (i+1<=len_trim(tmpline)) ! loop over all characters from TMPLINE
1610 IF (tmpline(i:i) == backslash ) THEN
1611 i=i+1
1612 IF (i-2>=1) THEN
1613 WRITE(tmpbuf,'(A,A)')tmpline(iold:i-2),tmpline(i:i)
1614 buflen=i-2-iold+1+1
1615 ELSE
1616 WRITE(tmpbuf,'(A)')tmpline(i:i)
1617 buflen=1
1618 END IF
1619 i=i+1
1620 iold=i
1621 ELSE IF (tmpline(i:i)=='%') THEN
1622 i=i+1
1623 IF (i-2>=1) THEN
1624 WRITE(tmpbuf,'(A)')tmpline(iold:i-2)
1625 buflen=i-2-iold+1
1626 IF (buflen>0) THEN
1627 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
1628 indxtmpout=indxtmpout+buflen
1629 buflen=0
1630 END IF
1631 END IF
1632 IF (tmpline(i:i)=='d') THEN
1633 i=i+1
1634 iold=i
1635 myfmt='(I10)'
1636 indxi=indxi+1
1637 IF(itype == 4)THEN
1638 WRITE(tmpbuf,myfmt)tmp_integer(indxi)
1639 tmpbuf=adjustl(tmpbuf)
1640 buflen=10
1641 ELSE
1642 WRITE(tmpbuf,myfmt)ibuf(indxi)
1643 tmpbuf=adjustl(tmpbuf)
1644 buflen=len_trim(tmpbuf)
1645 ENDIF
1646 ELSE IF (tmpline(i:i)=='f') THEN
1647 i=i+1
1648 iold=i
1649 myfmt='(1pg20.13)'
1650 indxr=indxr+1
1651 IF(itype == 4)THEN
1652 WRITE(tmpbuf,myfmt)tmp_real(indxr)
1653 tmpbuf=adjustl(tmpbuf)
1654 buflen=20
1655 ELSE
1656 WRITE(tmpbuf,myfmt)rbuf(indxr)
1657 tmpbuf=adjustl(tmpbuf)
1658 buflen=len_trim(tmpbuf)
1659 ENDIF
1660 ELSE IF (tmpline(i:i)=='s') THEN
1661 i=i+1
1662 iold=i
1663 myfmt='(A)'
1664 indxc=indxc+1
1665 IF(itype == 4)THEN
1666 WRITE(tmpbuf,myfmt)tmp_char(indxc)
1667 ELSE
1668 WRITE(tmpbuf,myfmt)cbuf(indxc)
1669 ENDIF
1670 tmpbuf=adjustl(tmpbuf)
1671 buflen=len_trim(tmpbuf)
1672 ELSE IF (tmpline(i:i)=='r') THEN
1673 i=i+1
1674 iold=i
1675 myfmt='(I10)'
1676 WRITE(tmpbuf,myfmt)nb_messages
1677 tmpbuf=adjustl(tmpbuf)
1678 buflen=len_trim(tmpbuf)
1679 ELSE IF (tmpline(i:i)=='i') THEN
1680 isav=i
1681 i=i+1
1682 IF(dyna_message == 1) THEN
1683
1684 CALL mess_extract_format(tmpline(i:ncharline),len_trim(tmpline(i:ncharline)),ncount,id_num,key,key_len) ! format is %iXX="/KEY" XX=1-11
1685
1686 i=i+ncount
1687 iold=i
1688 myfmt='(A)'
1689 indxd=indxd+1
1690 IF(itype == 4)THEN
1691 WRITE(tmpbuf,myfmt)tmp_i(indxd)
1692 ELSE
1693 option_name_dyna=' '
1694 s_option_name_dyna=1
1695
1696 CALL cpp_find_dyna_mess(key,key_len,ibuf(id_num),option_name_dyna,
1697 * s_option_name_dyna,isav,dyna_title,sdyna_title)
1698 WRITE(tmpbuf,myfmt) option_name_dyna(1:s_option_name_dyna)
1699 ENDIF
1700 tmpbuf=adjustl(tmpbuf)
1701 buflen=len_trim(tmpbuf)
1702 ELSE
1703 no_print = 1 ! Line with %i should not be print in case of native format.
1704 ENDIF
1705 ELSE
1706 i=i+1
1707 END IF
1708 ELSE
1709 i=i+1
1710 END IF
1711 IF (buflen>0) THEN
1712 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
1713 indxtmpout=indxtmpout+buflen
1714 buflen=0
1715 END IF
1716 END DO
1717 IF (iold<=i) THEN
1718 WRITE(tmpbuf,'(A)')
1719 * tmpline(iold:len_trim(tmpline))
1720 buflen=len_trim(tmpline)-iold+1
1721 IF (buflen>0) THEN
1722 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
1723 indxtmpout=indxtmpout+buflen
1724 buflen=0
1725 END IF
1726 END IF
1727 IF (indxtmpout>0.AND.
1728 . mes_double(cpt) == 0) THEN
1729C do not write title on stdo in case ANINFO_BLIND_2
1730 IF ( no_print == 0 ) THEN ! Line with %i should not be print in case of native format.
1731 IF (itype==1) THEN
1732 IF (anmode==aninfo.OR.
1733 * anmode==aninfo_blind_1) THEN
1734 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
1735 END IF
1736 IF (istdo/=iout) THEN
1737 IF (iout/=0) THEN
1738 WRITE(iout,'(A)')tmpout(1:indxtmpout)
1739 ELSE
1740C do not lose information
1741 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
1742 END IF
1743C IF (IOUTMSG/=0) THEN
1744C WRITE(IOUTMSG,'(A)')TMPOUT(1:INDXTMPOUT)
1745C ELSE
1746CC do not lose information
1747C WRITE(ISTDO,'(A)')TMPOUT(1:INDXTMPOUT)
1748C END IF
1749 END IF
1750 ELSE
1751C other information written on stdo only in case ANINFO
1752 IF (iline==1) THEN
1753 IF (anmode==aninfo) THEN
1754 IF(itype /= 4) WRITE(istdo,'(A)')ctype
1755 END IF
1756 IF (istdo/=iout) THEN
1757 IF (iout/=0) THEN
1758 IF(itype /= 4) WRITE(iout,'(A)')ctype
1759 ELSE
1760C do not lose information
1761 IF(itype /= 4) WRITE(istdo,'(A)')ctype
1762 END IF
1763 END IF
1764C IF (IOUTMSG/=0) THEN
1765C WRITE(IOUTMSG,'(A)')CTYPE
1766C ELSE
1767CC do not lose information
1768C WRITE(ISTDO,'(A)')CTYPE
1769C END IF
1770 END IF
1771
1772 IF (anmode==aninfo) THEN
1773 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
1774 END IF
1775 IF (istdo/=iout) THEN
1776 IF (iout/=0) THEN
1777 WRITE(iout,'(A)')tmpout(1:indxtmpout)
1778 ELSE
1779C do not lose information
1780 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
1781 END IF
1782 END IF
1783C IF (IOUTMSG/=0) THEN
1784C WRITE(IOUTMSG,'(A)')TMPOUT(1:INDXTMPOUT)
1785C ELSE
1786CC do not lose information
1787C WRITE(ISTDO,'(A)')TMPOUT(1:INDXTMPOUT)
1788C END IF
1789 END IF
1790 END IF ! IF NO_PRINT == 1
1791 END IF
1792C IF (ITYPE==3.AND.LEN_TRIM(TMPLINE)==0) THEN
1793 END IF
1794 END DO
1795 ENDDO
1796 END IF
1797 END DO
1798 DEALLOCATE(tmp_integer,tmp_real,tmp_char,index,itri,mes_double)
1799
1800 ENDIF
1801
1802c CLOSE (UNIT=RES_MES,STATUS='DELETE')
1803c OPEN (UNIT=RES_MES,STATUS='SCRATCH',FORM='FORMATTED')
1804c REWIND(RES_TMP)
1805c
1806c IEND = 0
1807c DO WHILE(IEND/=1)
1808c READ(RES_TMP,'(A)',END=140) TMPIN
1809c WRITE(RES_MES,'(A)') TMPIN
1810c ENDDO
1811c140 CONTINUE
1812c CLOSE (UNIT=RES_TMP,STATUS='DELETE')
1813 rewind res_tmp
1814 CLOSE (unit=res_mes)
1815 itmp = res_mes
1816 res_mes = res_tmp
1817 res_tmp = itmp
1818
1819 ENDIF
1820 ELSE ! PRMODE Was not set / No Message Stacking.
1821c not cummu/print part (old one)
1822C
1823c-----------------------------------------------------------
1824c MESSAGE SUMMARY
1825c-----------------------------------------------------------
1826 myfmt='(A,X,A)'
1827 IF(msgtype == 0) THEN
1828 WRITE(res_check,myfmt) 'M_OPTION=',err_category(1:len_trim(err_category))
1829 ELSEIF(msgtype == 1) THEN
1830 WRITE(res_check,myfmt) 'W_OPTION=',err_category(1:len_trim(err_category))
1831 ELSEIF(msgtype == 2) THEN
1832 WRITE(res_check,myfmt) 'E_OPTION=',err_category(1:len_trim(err_category))
1833 ENDIF
1834 myfmt='(A,I10,X)'
1835 WRITE(res_check,myfmt) 'OPTION_TYPE=',0
1836 IF(PRESENT(i1))THEN
1837 WRITE(res_check,myfmt) 'OPTION_ID=',i1
1838 ELSE
1839 WRITE(res_check,myfmt) 'OPTION_ID=',0
1840 ENDIF
1841 myfmt='(A,X,A)'
1842 IF(PRESENT(c1))THEN
1843 WRITE(res_check,myfmt) 'TITLE=',c1(1:len_trim(c1))
1844 ELSE
1845 WRITE(res_check,myfmt) 'TITLE=',''
1846 ENDIF
1847 myfmt='(A,I10,X)'
1848 WRITE(res_check,myfmt) 'ID_MES=',msgid
1849 WRITE(res_check,myfmt) 'NB_REPET=',1
1850C
1851 cmsgtype=' '
1852 IF (msgtype==0) THEN
1853 cmsgtype='MESSAGE'
1854 imsg=imsg+1
1855 ELSE IF (msgtype==1) THEN
1856 cmsgtype='WARNING'
1857 iwarn=iwarn+1
1858 ELSE IF (msgtype==2) THEN
1859 cmsgtype='ERROR'
1860 ierr=ierr+1
1861 END IF
1862 iexist=0
1863 DO itype=1,smsgtype
1864 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
1865 iexist=1
1866 END IF
1867 END DO
1868 IF (iexist == 0) THEN
1869 WRITE(istdo,'(A,A,A,I6)')'CALL TO UNEXISTING ',
1870 . cmsgtype(1:len_trim(cmsgtype)),
1871 . ' ID = ',
1872 . msgid
1873 IF (iout/=0) THEN
1874 WRITE(iout,'(A,A,A,I6)')'CALL TO UNEXISTING ',
1875 . cmsgtype(1:len_trim(cmsgtype)),
1876 . ' ID = ',
1877 . msgid
1878 END IF
1879 RETURN
1880 END IF
1881 IF (anmode/=aninfo_blind_2) THEN
1882 WRITE(istdo,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))//' ID : ',msgid
1883 END IF
1884 IF (istdo/=iout) THEN
1885 IF (iout/=0) THEN
1886 WRITE(iout,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))//' ID : ',msgid
1887 ELSE
1888 WRITE(istdo,'(/A,I6)')cmsgtype(1:len_trim(cmsgtype))//' ID : ',msgid
1889 END IF
1890 END IF
1891 ibuf=0
1892 rbuf=zero
1893 cbuf=' '
1894C
1895 indxi=0
1896 indxr=0
1897 indxc=0
1898C
1899 tmpout=' '
1900 indxtmpout=0
1901 tmpbuf=' '
1902C
1903 IF (PRESENT(i1)) THEN
1904 ibuf(1)=i1
1905 IF (PRESENT(i2)) THEN
1906 ibuf(2)=i2
1907 IF (PRESENT(i3)) THEN
1908 ibuf(3)=i3
1909 IF (PRESENT(i4)) THEN
1910 ibuf(4)=i4
1911 IF (PRESENT(i5)) THEN
1912 ibuf(5)=i5
1913 IF (PRESENT(i6)) THEN
1914 ibuf(6)=i6
1915 IF (PRESENT(i7)) THEN
1916 ibuf(7)=i7
1917 IF (PRESENT(i8)) THEN
1918 ibuf(8)=i8
1919 IF (PRESENT(i9)) THEN
1920 ibuf(9)=i9
1921 IF (PRESENT(i10)) THEN
1922 ibuf(10)=i10
1923 IF (PRESENT(i11)) THEN
1924 ibuf(11)=i11
1925 IF (PRESENT(i12)) THEN
1926 ibuf(12)=i12
1927 IF (PRESENT(i13)) THEN
1928 ibuf(13)=i13
1929 IF (PRESENT(i14)) THEN
1930 ibuf(14)=i14
1931 IF (PRESENT(i15)) THEN
1932 ibuf(15)=i15
1933 IF (PRESENT(i16)) THEN
1934 ibuf(16)=i16
1935 IF (PRESENT(i17)) THEN
1936 ibuf(17)=i17
1937 IF (PRESENT(i18)) THEN
1938 ibuf(18)=i18
1939 IF (PRESENT(i19)) THEN
1940 ibuf(19)=i19
1941 IF (PRESENT(i20)) THEN
1942 ibuf(20)=i20
1943 END IF
1944 END IF
1945 END IF
1946 END IF
1947 END IF
1948 END IF
1949 END IF
1950 END IF
1951 END IF
1952 END IF
1953 END IF
1954 END IF
1955 END IF
1956 END IF
1957 END IF
1958 END IF
1959 END IF
1960 END IF
1961 END IF
1962 END IF
1963C
1964 IF (PRESENT(r1)) THEN
1965 rbuf(1)=r1
1966 IF (PRESENT(r2)) THEN
1967 rbuf(2)=r2
1968 IF (PRESENT(r3)) THEN
1969 rbuf(3)=r3
1970 IF (PRESENT(r4)) THEN
1971 rbuf(4)=r4
1972 IF (PRESENT(r5)) THEN
1973 rbuf(5)=r5
1974 IF (PRESENT(r6)) THEN
1975 rbuf(6)=r6
1976 IF (PRESENT(r7)) THEN
1977 rbuf(7)=r7
1978 IF (PRESENT(r8)) THEN
1979 rbuf(8)=r8
1980 IF (PRESENT(r9)) THEN
1981 rbuf(9)=r9
1982 END IF
1983 END IF
1984 END IF
1985 END IF
1986 END IF
1987 END IF
1988 END IF
1989 END IF
1990 END IF
1991C
1992 IF (PRESENT(c1)) THEN
1993 cbuf(1)=c1
1994 IF (PRESENT(c2)) THEN
1995 cbuf(2)=c2
1996 IF (PRESENT(c3)) THEN
1997 cbuf(3)=c3
1998 IF (PRESENT(c4)) THEN
1999 cbuf(4)=c4
2000 IF (PRESENT(c5)) THEN
2001 cbuf(5)=c5
2002 IF (PRESENT(c6)) THEN
2003 cbuf(6)=c6
2004 IF (PRESENT(c7)) THEN
2005 cbuf(7)=c7
2006 IF (PRESENT(c8)) THEN
2007 cbuf(8)=c8
2008 IF (PRESENT(c9)) THEN
2009 cbuf(9)=c9
2010 END IF
2011 END IF
2012 END IF
2013 END IF
2014 END IF
2015 END IF
2016 END IF
2017 END IF
2018 END IF
2019C
2020 DO itype=1,smsgtype
2021 IF (itype==1) THEN
2022 ctype=''
2023 ELSE IF (itype==2) THEN
2024C WRITE(CTYPE,'(A,/)')"DESCRIPTION : "
2025 ctype='DESCRIPTION : '
2026 ELSE IF (itype==3) THEN
2027 ctype='SOLUTION : '
2028 END IF
2029 IF (ALLOCATED(messages(itype,msgid)%MESSAGE)) THEN
2030 iline = 0
2031 DO WHILE (iline < messages(itype,msgid)%SMESSAGE)
2032 iline = iline + 1
2033 IF (iline>1) ctype=''
2034 tmpout=' '
2035 tmpbuf=' '
2036C IF (ITYPE==3.AND.LEN_TRIM(TMPLINE)==0) THEN
2037 IF (messages(itype,msgid)%SMESSAGE/=0) THEN
2038 tmpline=messages(itype,msgid)%MESSAGE(iline)
2039 buflen=0
2040 indxtmpout=0
2041 i=1
2042 iold=1
2043! DO J0=1,LEN_TRIM(TMPLINE)
2044! IF (TMPLINE(J0:J0)=='/') THEN
2045! TMPLINE(J0:J0)=CHAR(10)
2046! END IF
2047! END DO
2048 no_print = 0
2049 IF ( msgid >= 100000 .AND. iline >= 3 ) THEN
2050c HM_READER messages ( line with error sent by reader)
2051 i=i+1
2052 iold=i
2053 myfmt='(A)'
2054 IF (indxc<10) indxc=indxc+1
2055 WRITE(tmpbuf,myfmt)cbuf(indxc)
2056 tmpbuf=adjustl(tmpbuf)
2057 buflen=len_trim(tmpbuf)
2058 IF (buflen>0) THEN
2059 tmpout=tmpbuf(1:buflen)
2060 indxtmpout=indxtmpout+buflen
2061 buflen=0
2062 END IF
2063 iline = messages(itype,msgid)%SMESSAGE+1
2064 ELSEIF ( msgid > 200000 .AND. itype /= 1 ) THEN
2065c CONVERTER messages ( line with error sent by onverter)
2066 DO WHILE (i+1<=len_trim(tmpline))
2067 IF (tmpline(i:i) == backslash) THEN
2068 i=i+1
2069 IF (i-2>=1) THEN
2070 WRITE(tmpbuf,'(A,A)')tmpline(iold:i-2),tmpline(i:i)
2071 buflen=i-2-iold+1+1
2072 ELSE
2073 WRITE(tmpbuf,'(A)')tmpline(i:i)
2074 buflen=1
2075 END IF
2076 i=i+1
2077 iold=i
2078 ELSE
2079 i=i+1
2080 iold=i
2081 myfmt='(A)'
2082 IF (indxc<10) indxc=indxc+1
2083 WRITE(tmpbuf,myfmt)cbuf(indxc)
2084 tmpbuf=adjustl(tmpbuf)
2085 buflen=len_trim(tmpbuf)
2086 END IF
2087 IF (buflen>0) THEN
2088 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
2089 indxtmpout=indxtmpout+buflen
2090 buflen=0
2091 END IF
2092 END DO
2093 ELSE ! IF ( (MSGID >= 100000 .AND. ILINE >= 3)) THEN ! !
2094 DO WHILE (i+1<=len_trim(tmpline))
2095 IF (tmpline(i:i)==backslash) THEN
2096 i=i+1
2097 IF (i-2>=1) THEN
2098 WRITE(tmpbuf,'(A,A)')tmpline(iold:i-2),tmpline(i:i)
2099 buflen=i-2-iold+1+1
2100 ELSE
2101 WRITE(tmpbuf,'(A)')tmpline(i:i)
2102 buflen=1
2103 END IF
2104 i=i+1
2105 iold=i
2106 ELSE IF (tmpline(i:i)=='%') THEN
2107 i=i+1
2108 IF (i-2>=1) THEN
2109 WRITE(tmpbuf,'(A)')tmpline(iold:i-2)
2110 buflen=i-2-iold+1
2111 IF (buflen>0) THEN
2112 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
2113 indxtmpout=indxtmpout+buflen
2114 buflen=0
2115 END IF
2116 END IF
2117
2118 IF (tmpline(i:i)=='d') THEN ! %d (integer) replaced with its value
2119 i=i+1
2120 iold=i
2121 myfmt='(I10)'
2122 IF (indxi<=20) indxi=indxi+1
2123 WRITE(tmpbuf,myfmt)ibuf(indxi)
2124 tmpbuf=adjustl(tmpbuf)
2125 buflen=len_trim(tmpbuf)
2126
2127 ELSE IF (tmpline(i:i)=='f') THEN ! %f (float) replaced with its value
2128 i=i+1
2129 iold=i
2130 myfmt='(1pg20.13)'
2131 IF (indxr<10) indxr=indxr+1
2132 WRITE(tmpbuf,myfmt)rbuf(indxr)
2133 tmpbuf=adjustl(tmpbuf)
2134 buflen=len_trim(tmpbuf)
2135
2136 ELSE IF (tmpline(i:i)=='s') THEN ! %s (string) replaced with its value
2137 i=i+1
2138 iold=i
2139 myfmt='(A)'
2140 IF (indxc<10) indxc=indxc+1
2141 WRITE(tmpbuf,myfmt)cbuf(indxc)
2142 tmpbuf=adjustl(tmpbuf)
2143 buflen=len_trim(tmpbuf)
2144
2145 ELSEIF (tmpline(i:i)=='i') THEN ! New format %ixxx be computed - for test add fmt
2146 isav=i
2147 i=i+1
2148 IF(dyna_message == 1) THEN
2149 CALL mess_extract_format(tmpline(i:ncharline),len_trim(tmpline(i:ncharline)),ncount,id_num,key,key_len) ! format is %iXX="/KEY" XX=1-11
2150 i=i+ncount
2151 iold=i
2152 option_name_dyna=' '
2153 s_option_name_dyna=1
2154
2155 CALL cpp_find_dyna_mess(key,key_len,ibuf(id_num),option_name_dyna,
2156 * s_option_name_dyna,isav,dyna_title,sdyna_title)
2157
2158 myfmt='(A)'
2159 WRITE(tmpbuf,myfmt) option_name_dyna(1:s_option_name_dyna)
2160 tmpbuf=adjustl(tmpbuf)
2161 buflen=len_trim(tmpbuf)+1
2162 ELSE
2163 no_print=1
2164 i=i+1
2165 END IF
2166 END IF
2167 ELSE
2168 i=i+1
2169 END IF
2170 IF (buflen>0) THEN
2171 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
2172 indxtmpout=indxtmpout+buflen
2173 buflen=0
2174 indxtmpout=min(indxtmpout,ncharline)
2175 END IF
2176 END DO
2177 IF (iold<=i) THEN
2178 WRITE(tmpbuf,'(A)')
2179 * tmpline(iold:len_trim(tmpline))
2180 buflen=len_trim(tmpline)-iold+1
2181 IF (buflen>0) THEN
2182 tmpout=tmpout(1:indxtmpout)//tmpbuf(1:buflen)
2183 indxtmpout=indxtmpout+buflen
2184 buflen=0
2185 indxtmpout=min(indxtmpout,ncharline)
2186 END IF
2187 END IF
2188 ENDIF
2189 indxtmpout=min(indxtmpout,ncharline)
2190 IF (indxtmpout>0) THEN
2191C do not write title on stdo in case ANINFO_BLIND_2
2192 IF(no_print == 0)THEN ! NO_PRINT is set to 1 when %i is found &
2193 IF (itype==1) THEN
2194 IF (anmode==aninfo.OR.
2195 * anmode==aninfo_blind_1) THEN
2196 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
2197 END IF
2198 IF (istdo/=iout) THEN
2199 IF (iout/=0) THEN
2200 WRITE(iout,'(A)')tmpout(1:indxtmpout)
2201 ELSE
2202C do not lose information
2203 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
2204 END IF
2205C IF (IOUTMSG/=0) THEN
2206C WRITE(IOUTMSG,'(A)')TMPOUT(1:INDXTMPOUT)
2207C ELSE
2208CC do not lose information
2209C WRITE(ISTDO,'(A)')TMPOUT(1:INDXTMPOUT)
2210C END IF
2211 END IF
2212 ELSE
2213C other information written on stdo only in case ANINFO
2214 IF (iline==1) THEN
2215 IF (anmode==aninfo) THEN
2216 WRITE(istdo,'(A)')ctype
2217 END IF
2218 IF (istdo/=iout) THEN
2219 IF (iout/=0) THEN
2220 WRITE(iout,'(A)')ctype
2221 ELSE
2222C do not lose information
2223 WRITE(istdo,'(A)')ctype
2224 END IF
2225 END IF
2226C IF (IOUTMSG/=0) THEN
2227C WRITE(IOUTMSG,'(A)')CTYPE
2228C ELSE
2229CC do not lose information
2230C WRITE(ISTDO,'(A)')CTYPE
2231C END IF
2232 END IF
2233 IF (anmode==aninfo) THEN
2234 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
2235 END IF
2236 IF (istdo/=iout) THEN
2237 IF (iout/=0) THEN
2238 WRITE(iout,'(A)')tmpout(1:indxtmpout)
2239 ELSE
2240C do not lose information
2241 WRITE(istdo,'(A)')tmpout(1:indxtmpout)
2242 END IF
2243 END IF
2244C IF (IOUTMSG/=0) THEN
2245C WRITE(IOUTMSG,'(A)')TMPOUT(1:INDXTMPOUT)
2246C ELSE
2247CC do not lose information
2248C WRITE(ISTDO,'(A)')TMPOUT(1:INDXTMPOUT)
2249C END IF
2250 END IF
2251 END IF ! NO_PRINT is set to 1 when %i is found &
2252 END IF
2253C IF (ITYPE==3.AND.LEN_TRIM(TMPLINE)==0) THEN
2254 END IF
2255 END DO
2256 END IF
2257 END DO
2258 ENDIF
2259c
2260 IF (anmode == anstop .AND. PRESENT(prmode)) THEN
2261 IF (prmode == 1 .AND. nbrepet /= 0) THEN
2262C Care MSGID is ERROR TRAPPED -> Exit code must be 3
2263 IF(msgid == 760) THEN
2264 CALL arret(3)
2265 ELSE
2266 CALL arret(2)
2267 ENDIF
2268 ENDIF
2269 ELSEIF (anmode == anstop) THEN
2270C Care MSGID is ERROR TRAPPED -> Exit code must be 3
2271 IF(msgid == 760) THEN
2272 CALL arret(3)
2273 ELSE
2274 CALL arret(2)
2275 ENDIF
2276 ENDIF
2277c
2278 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod2
Definition message_mod2.F:30
message_mod2::smsgtype
integer smsgtype
Definition message_mod2.F:42
message_mod2::dyna_message
integer dyna_message
Definition message_mod2.F:57
message_mod2::aninfo_blind_1
integer aninfo_blind_1
Definition message_mod2.F:51
message_mod2::anstop
integer anstop
Definition message_mod2.F:52
message_mod2::aninfo
integer aninfo
Definition message_mod2.F:51
message_mod2::messages
type(tmessage), dimension(:,:), allocatable messages
Definition message_mod2.F:40
message_mod2::imsg
integer imsg
Definition message_mod2.F:53
message_mod2::ierr
integer ierr
Definition message_mod2.F:53
message_mod2::err_category
character(len=ncharline) err_category
Definition message_mod2.F:73
message_mod2::iwarn
integer iwarn
Definition message_mod2.F:53
message_mod2::aninfo_blind_2
integer aninfo_blind_2
Definition message_mod2.F:51
mess_extract_format
subroutine mess_extract_format(tmpline, line_size, ncount, id_num, key, key_len)
Definition message.F:2289
nl
character *2 function nl()
Definition message.F:2354
arret
subroutine arret(nn)
Definition arret.F:87

◆ mess_extract_format()

subroutine mess_extract_format ( character, dimension(line_size), intent(in) tmpline,
integer, intent(in) line_size,
integer, intent(out) ncount,
integer, intent(out) id_num,
character, dimension(ncharline), intent(out) key,
integer, intent(out) key_len )

Definition at line 2288 of file message.F.

2289C-----------------------------------------------
2290C M o d u l e s
2291C-----------------------------------------------
2292 USE names_and_titles_mod , ONLY : ncharline
2293C-----------------------------------------------
2294C I m p l i c i t T y p e s
2295C-----------------------------------------------
2296#include "implicit_f.inc"
2297C-----------------------------------------------
2298C D u m m y A r g u m e n t s
2299C-----------------------------------------------
2300 INTEGER, INTENT(IN) :: LINE_SIZE ! site of tmpline
2301 CHARACTER, INTENT(IN),DIMENSION(LINE_SIZE) :: TMPLINE ! input string with format
2302
2303 INTEGER, INTENT(OUT) :: NCOUNT ! format length
2304 INTEGER, INTENT(OUT) :: ID_NUM ! processed ID indice
2305 CHARACTER, INTENT(OUT),DIMENSION(NCHARLINE) :: KEY ! output string with option type
2306 INTEGER, INTENT(OUT) :: KEY_LEN ! output string with option type
2307C-----------------------------------------------
2308C L o c a l V a r i a b l e s
2309C-----------------------------------------------
2310 INTEGER I,BRACKETS_COUNT,NUMB_COUNT,EQUAL_FOUND
2311 CHARACTER, DIMENSION(10) :: NUMB
2312C-----------------------------------------------
2313 numb_count=0
2314 numb(1:10)=' '
2315 i=1
2316 brackets_count=0
2317 ncount=0
2318 id_num=0
2319 key_len=0
2320 equal_found=0
2321
2322 DO WHILE( brackets_count /= 2 .AND. i<=line_size)
2323
2324 IF(tmpline(i) == '"') THEN
2325 brackets_count=brackets_count+1
2326 i=i+1 ! move one forward
2327 IF(i > line_size)EXIT
2328 ENDIF
2329
2330 IF(tmpline(i) == '=') THEN
2331 equal_found=1
2332 ENDIF
2333
2334 IF(equal_found==0)THEN
2335 numb_count=numb_count+1
2336 numb(numb_count)=tmpline(i)
2337 ENDIF
2338
2339 IF(brackets_count==1)THEN ! copying in key
2340 key_len=key_len+1
2341 key(key_len)=tmpline(i)
2342 ENDIF
2343
2344 ncount=ncount+1
2345 i=i+1
2346 ENDDO
2347 ncount=ncount+1 ! move one forward to skip the brackets
2348 READ(numb,'(I10)') id_num
2349
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::ncharline
integer, parameter ncharline
Definition names_and_titles_mod.F:1001

◆ nl()

character*2 function nl

Definition at line 2353 of file message.F.

2354C |====================================================================
2355C | Routine to set Carriage return according to different OS flavours
2356C | Linux : CR - CHAR(10)
2357C | Windows : CR/LF - CHAR(13)CHAR(10)
2358C |====================================================================
2359 CHARACTER*2 CR
2360#ifdef _WIN64
2361 cr=char(13)//char(10)
2362#else
2363 cr=' '//char(10)
2364#endif
2365 nl=cr
2366 RETURN