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 885 of file message.F.

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

◆ 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 2294 of file message.F.

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

◆ nl()

character*2 function nl

Definition at line 2359 of file message.F.

2360C |====================================================================
2361C | Routine to set Carriage return according to different OS flavours
2362C |Linux: CR - Char (10)
2363C | Windows : CR/LF - CHAR(13)CHAR(10)
2364C |====================================================================
2365 CHARACTER*2 CR
2366#ifdef _WIN64
2367 cr=char(13)//char(10)
2368#else
2369 cr=' '//char(10)
2370#endif
2371 nl=cr
2372 RETURN