|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 C Jan-2011 P. Marguinaud Thread-safe LFI 00002 SUBROUTINE LFIENG_MT (LFI, KNUMER, KNIMES, KCODE, LDFATA, 00003 S CDMESS, CDNSPR,CDACTI ) 00004 USE LFIMOD, ONLY : LFICOM 00005 USE PARKIND1, ONLY : JPRB 00006 USE YOMHOOK , ONLY : LHOOK, DR_HOOK 00007 C**** 00008 C THIS SUBROUTINE PRINTS STANDARD MESSAGES FROM LFI INDEXED- 00009 C FILE SOFTWARE, ABORTING PROGRAM IF REQUIRED. 00010 C Messages related to "debugging mode" are directly printed 00011 C by concerned subroutines. 00012 C 00013 C This subroutine is the english version, translated from the 00014 C the original (french) one, and is always called through the 00015 C "hat" routine LFIEMS. 00016 C For french version see subroutine LFIEFR. 00017 C ( Pour la version francaise, voir LFIEFR ) 00018 C** 00019 C DUMMY ARGUMENTS : KNUMER ==> Logical Unit concerned, if any; 00020 C ( all INPUT ones ) ( if LFI%JPNIL ==> no Logical Unit ) 00021 C KNIMES ==> Level (0,1,2) of Message; 00022 C KCODE ==> Response code of action concerned; 00023 C LDFATA ==> True if Abort of program is required; 00024 C CDMESS ==> If KNIMES#0, Message to print; 00025 C CDNSPR ==> Subroutine name which calls LFIEMS; 00026 C CDACTI ==> Name of FORTRAN input/output action 00027 C if KCODE >0, else... it depends ! 00028 C* 00029 C !----------------------------------------------------------------! 00030 C ! TABLE OF POSSIBLE VALUES FOR RESPONSE CODES OF LFI SOFTWARE ! 00031 C !----------------------------------------------------------------! 00032 C 00033 C----------------------------------------------------------------------- 00034 C 0 ==> No error has been detected, everything is OK. 00035 C----------------------------------------------------------------------- 00036 Cpositive==> It is the (absolute value of) FORTRAN response code 00037 C value from an OPEN, READ, WRITE, CLOSE or INQUIRE instruction; 00038 C see vendor's reference manual for exact meaning. 00039 C----------------------------------------------------------------------- 00040 C -1 ==> Logical Unit currently not opened for the software. 00041 C----------------------------------------------------------------------- 00042 C -2 ==> "LEVEL" value outside [0-2] range . 00043 C----------------------------------------------------------------------- 00044 C -3 ==> Bad lock option (internal subroutine "LFIVER") . 00045 C----------------------------------------------------------------------- 00046 C -4 ==> Explicit change for Multi-Tasking mode, but almost one unit 00047 C is currently open-problems may arise (subroutine "LFIINI"). 00048 C----------------------------------------------------------------------- 00049 C -5 ==> Logical Unit is currently opened (LFIOUV, LFIAFM, LFISFM) . 00050 C----------------------------------------------------------------------- 00051 C -6 ==> Not enough space within tables to open requested Unit. 00052 C (LFIOUV) 00053 C----------------------------------------------------------------------- 00054 C -7 ==> Invalid "STATUS" for FORTRAN instruction "OPEN" (LFIOUV) . 00055 C----------------------------------------------------------------------- 00056 C -8 ==> Incompatible values given for "LDNOMM" and "CDSTTO": 00057 C a file which "STATUS" is 'OLD' or 'NEW' must have a name . 00058 C (LFIOUV) (THIS REPONSE CODE HAS CURRENTLY NO MORE SENSE) 00059 C----------------------------------------------------------------------- 00060 C -9 ==> Incompatibility between "STATUS" 'NEW' or 'OLD' and (respe- 00061 C ctively) file existence or non-existence (LFIOUV) . 00062 C----------------------------------------------------------------------- 00063 C -10 ==> The file is not a LFI one, or may not be treated through 00064 C this configuration or version of the software (LFIOUV) . 00065 C----------------------------------------------------------------------- 00066 C -11 ==> File not closed after a modification (LFIOUV): this 00067 C error is not fatal if "LDERFA" is .FALSE., but in such a 00068 C case file integrity and data coherence are not guaranteed. 00069 C Note that once a file has got such problem, this response 00070 C code will stay even after a subsequent modification. 00071 C----------------------------------------------------------------------- 00072 C -12 ==> File has a "STATUS" 'OLD' but an error occurred when 00073 C reading the first physical record of file (LFIOUV) . 00074 C----------------------------------------------------------------------- 00075 C -13 ==> File is already open for another LFI logical unit. 00076 C (LFIOUV) 00077 C----------------------------------------------------------------------- 00078 C -14 ==> Incorrect value for INTEGER argument (generally negative) . 00079 C----------------------------------------------------------------------- 00080 C -15 ==> Incorrect CHARACTER argument (too long, for instance). 00081 C----------------------------------------------------------------------- 00082 C -16 ==> Incoherence in Tables, File, internal calls, software. 00083 C THIS ERROR MAY NEVER BE FILTERED. ALWAYS FATAL. 00084 C----------------------------------------------------------------------- 00085 C -17 ==> Too many logical records to store an extra one (LFIECR) . 00086 C (note that logical records consist of user-readable data 00087 C records, but also of holes cataloged in index... which are 00088 C created when existing records may not be rewritten in 00089 C place, or when records are suppressed; such holes may be 00090 C "re-cycled") 00091 C----------------------------------------------------------------------- 00092 C -18 ==> A logical record name formed only with SPACES is invalid. 00093 C (for internal use of LFI software, holes in index are 00094 C described by a blank record name) 00095 C----------------------------------------------------------------------- 00096 C -19 ==> File opened with "STATUS" set to 'SCRATCH', so may not be 00097 C kept at CLOSE time: 'KEEP' is illicit for "CDSTTC" (LFIFER) 00098 C if this error is not fatal, then a FORTRAN "CLOSE" without 00099 C "STATUS" parameter is performed, in the same manner as if 00100 C "CDSTTC" is neither 'KEEP' nor 'DELETE'. 00101 C----------------------------------------------------------------------- 00102 C -20 ==> No logical record with such name found within logical unit. 00103 C (LFILEC, LFIREN, LFISUP) 00104 C----------------------------------------------------------------------- 00105 C -21 ==> Requested logical record is LONGER (has more data) in file; 00106 C if this error is not fatal, then a PARTIAL read is 00107 C performed, at requested length. 00108 C (LFILAP, LFILAS, LFILEC) 00109 C----------------------------------------------------------------------- 00110 C -22 ==> Requested logical record SHORTER (has less data) in file; 00111 C even if this error is not fatal, NO READING OF DATA OCCURS. 00112 C (LFILAP, LFILAS, LFILEC) . 00113 C----------------------------------------------------------------------- 00114 C -23 ==> No or no more "NEXT" record to read (LFILAS) . 00115 C----------------------------------------------------------------------- 00116 C -24 ==> The character variable given as actual output argument is 00117 C TOO SHORT to store the record NAME, even when suppressing 00118 C any spaces at the end of the name. 00119 C (LFICAP, LFICAS, LFILAP, LFILAS) 00120 C----------------------------------------------------------------------- 00121 C -25 ==> The new name of the logical record is (already) used for 00122 C another logical record within the file (LFIREN). 00123 C----------------------------------------------------------------------- 00124 C -26 ==> No or no more "PREVIOUS" logical record to read (LFILAP). 00125 C----------------------------------------------------------------------- 00126 C -27 ==> Insufficient CONTIGUOUS space within tables to treat the 00127 C "multiple" file requested (LFIOUV) . 00128 C----------------------------------------------------------------------- 00129 C -28 ==> Multiply factor (of elementary physical record length) too 00130 C big for the current configuration of the software. 00131 C (LFIOUV, LFIAFM, LFIFMD) 00132 C----------------------------------------------------------------------- 00133 C -29 ==> Not enough space within tables to store the multiply factor 00134 C to be associated to logical unit (LFIAFM) . 00135 C----------------------------------------------------------------------- 00136 C -30 ==> Logical unit number invalid for FORTRAN. 00137 C----------------------------------------------------------------------- 00138 C -31 ==> Logical unit has no multiply factor predefined. 00139 C (LFISFM) 00140 C----------------------------------------------------------------------- 00141 C 00142 #ifndef f77 00143 USE SDL_MOD , ONLY : SDL_SRLABORT 00144 #endif 00145 #ifndef f77 00146 #include "precision.h" 00147 #endif 00148 C 00149 TYPE(LFICOM) :: LFI 00150 INTEGER KNUMER, KNIMES, KCODE, ILDMES, ILBLAN, INLNOM, INUMER 00151 INTEGER IDECBL, IPOSBL, ILACTI, ILACT2, ILNSPR, ILMESU, IJL, J, IJ 00152 INTEGER INBALO, ILMESA, INLIGN, IDECAL 00153 C 00154 LOGICAL LDFATA 00155 C 00156 CHARACTER CDNSPR*(*), CLJOLI*6, CDMESS*(*), CLMESA*80, CDACTI*(*) 00157 C 00158 #include "lficom2.h" 00159 #include "lficom_mt.h" 00160 C** 00161 C 1. - INITIALISATIONS. 00162 C----------------------------------------------------------------------- 00163 C 00164 C Search for "useful" length of argument CDACTI. 00165 C (i.e. not taking into account any blank characters at the end) 00166 C 00167 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00168 IF (LHOOK) CALL DR_HOOK('LFIENG_MT',0,ZHOOK_HANDLE) 00169 IDECBL=0 00170 C 00171 101 CONTINUE 00172 IPOSBL=IDECBL+INDEX (CDACTI(IDECBL+1:),' ') 00173 C 00174 IF (IPOSBL.LE.IDECBL) THEN 00175 ILACTI=LEN (CDACTI) 00176 ELSEIF (CDACTI(IPOSBL:).EQ.' ') THEN 00177 ILACTI=IPOSBL-1 00178 ELSE 00179 IDECBL=IPOSBL 00180 GOTO 101 00181 ENDIF 00182 C 00183 ILACT2=MIN0 (ILACTI,LFI%JPNCPN) 00184 ILACTI=MIN0 (ILACT2,8) 00185 ILNSPR=MIN0 (LEN (CDNSPR),LFI%JPLSPX) 00186 C 00187 C Prefix (and possible suffix) for the message(s). 00188 C 00189 IF (LDFATA) THEN 00190 CLJOLI=' *****' 00191 ELSEIF (KNIMES.EQ.0.OR.KCODE.NE.0) THEN 00192 CLJOLI=' */*/*' 00193 ELSE 00194 CLJOLI=' /////' 00195 ENDIF 00196 C 00197 IF (KNIMES.NE.0) THEN 00198 C** 00199 C 2. - PRINTS MESSAGE PREPARED BY SUBROUTINE WHICH CALLED LFIEMS. 00200 C----------------------------------------------------------------------- 00201 C 00202 ILMESU=MIN0 (LEN (CLMESS)- 00203 S LEN (CLJOLI)-ILNSPR-4,LEN (CDMESS)) 00204 CLMESS=CLJOLI//' '//CDNSPR(1:ILNSPR)//' - ' 00205 S //CDMESS(1:ILMESU) 00206 WRITE (UNIT=LFI%NULOUT,FMT='(A)') CLMESS 00207 ENDIF 00208 C 00209 IF (KNIMES.EQ.0.OR.LDFATA) THEN 00210 C** 00211 C 3. - CONSTITUTION OF "AD HOC" MESSAGE, DEPENDING OF *KCODE*. 00212 C----------------------------------------------------------------------- 00213 C 00214 C Before, check if logical unit considered corresponds to a logical 00215 C unit currently opened for LFI software (or not). 00216 C 00217 IF (KNUMER.EQ.LFI%JPNIL) THEN 00218 IJL=0 00219 ELSE 00220 C 00221 DO 301 J=1,LFI%NBFIOU 00222 IJL=LFI%NUMIND(J) 00223 IF (KNUMER.EQ.LFI%NUMERO(IJL)) GOTO 302 00224 301 CONTINUE 00225 C 00226 IJL=0 00227 ENDIF 00228 C 00229 302 CONTINUE 00230 C 00231 IF (KCODE.GT.0) THEN 00232 C 00233 IF ((CDACTI.EQ.'READ'.OR.CDACTI.EQ.'WRITE') 00234 S .AND.LFI%NUMAPH(IJL).GT.0) THEN 00235 WRITE (UNIT=CLMESS,FMT='(''ERROR "'',A,''"' 00236 ',I7, S '',UNIT'',I3,'',REC.NUM'',I6,'',*' 00237 ',I6, S '' WORDS'')') CDACTI(1:ILACTI),KCODE,KNUMER, 00238 S LFI%NUMAPH(IJL), 00239 S LFI%JPLARD*LFI%MFACTM(IJL) 00240 ELSE 00241 WRITE (UNIT=CLMESS, 00242 S FMT='(''FORTRAN "'',A,''" ERROR, CODE=' 00243 ' S ,I7,'', UNIT='',I3)') CDACTI(1:ILACTI),KCODE,KNUMER 00244 ENDIF 00245 C 00246 ELSEIF (KCODE.EQ.-1) THEN 00247 WRITE (UNIT=CLMESS,FMT='(''LOGICAL UNIT' 00248 ',I3, S '' NOT OPENED FOR LFI SOFTWARE'')') KNUMER 00249 C 00250 ELSEIF (KCODE.EQ.-2) THEN 00251 C 00252 IF (KNUMER.EQ.LFI%JPNIL) THEN 00253 CLMESS='ACTUAL VALUE FOR LEVEL "KNIVAU" '// 00254 S 'OUTSIDE [0-2] RANGE' 00255 ELSE 00256 WRITE (UNIT=CLMESS,FMT= 00257 S '(''MESSAGE LEVEL OUTSIDE [0-2] RANGE, UNIT'',I3)') KNUMER 00258 ENDIF 00259 C 00260 ELSEIF (KCODE.EQ.-3) THEN 00261 ILDMES=MIN0 (8,LEN (CDMESS)) 00262 CLMESS='UNKNOWN ACTION '''//CDMESS(1:ILDMES) 00263 S //''' ON LOCKS' 00264 C 00265 ELSEIF (KCODE.EQ.-4) THEN 00266 CLMESS='EXPL.CHANGE OF MULTI-TASKING MODE '// 00267 S 'WITH UNIT(S) OPENED' 00268 C 00269 ELSEIF (KCODE.EQ.-5) THEN 00270 WRITE (UNIT=CLMESS,FMT='(''LOGICAL UNIT' 00271 ',I3, S '' ALREADY OPENED FOR LFI - AND SHOULD NOT.'')') KNUMER 00272 C 00273 ELSEIF (KCODE.EQ.-6) THEN 00274 WRITE (UNIT=CLMESS,FMT='(I3,'' ENTRIES,' 00275 ', S '' NOT ENOUGH PLACE WITHIN TABLES FOR UNIT'',I3)') 00276 S LFI%JPNXFI,KNUMER 00277 C 00278 ELSEIF (KCODE.EQ.-7) THEN 00279 WRITE (UNIT=CLMESS,FMT='(''FORTRAN STATUS''''' 00280 ',A, S '''''' UNKNOWN, UNIT'',I3)') CDACTI(1:ILACTI),KNUMER 00281 C 00282 ELSEIF (KCODE.EQ.-8) THEN 00283 WRITE (UNIT=CLMESS,FMT='(''UNIT'',I3,'' OF STATUS ''''' 00284 ' S,A,'''''' MUST HAVE AN EXPLICIT NAME'')') KNUMER,CDACTI(1:ILACTI) 00285 C 00286 ELSEIF (KCODE.EQ.-9) THEN 00287 C 00288 IF (CDACTI.EQ.'OLD') THEN 00289 WRITE (UNIT=CLMESS,FMT= 00290 S'(''STATUS ''''OLD'''' BUT FILE DOES NOT EXIST, UNIT' 00291 ', S I3)') KNUMER 00292 ELSE 00293 ILBLAN=INDEX (CDACTI(1:ILACTI),' ') 00294 IF (ILBLAN.GT.1) ILACTI=ILBLAN-1 00295 WRITE (UNIT=CLMESS,FMT= 00296 S'(''STATUS '''''',A,'''''' BUT FILE ALREADY EXISTS, UNIT' 00297 ', S I3)') CDACTI(1:ILACTI),KNUMER 00298 ENDIF 00299 C 00300 ELSEIF (KCODE.EQ.-10) THEN 00301 WRITE (UNIT=CLMESS,FMT='(''INCOMPATIBILITY' 00302 ', S '' FILE / SOFTWARE, UNIT'',I3)') KNUMER 00303 C 00304 ELSEIF (KCODE.EQ.-11) THEN 00305 WRITE (UNIT=CLMESS, 00306 S FMT='(''UNIT'',I3,'' NOT CLOSED AFTER ' 00307 ', S ''ITS LAST MODIFICATION'')') KNUMER 00308 C 00309 ELSEIF (KCODE.EQ.-12) THEN 00310 WRITE (UNIT=CLMESS,FMT='(''UNIT' 00311 ',I3, S '' OF STATUS ''''OLD'''' - READ OF FIRST RECORD FAILED'')') 00312 S KNUMER 00313 C 00314 ELSEIF (KCODE.EQ.-13) THEN 00315 INLNOM=1 00316 INUMER=LFI%JPNIL 00317 C 00318 DO 131 J=1,LFI%NBFIOU 00319 IJ=LFI%NUMIND(J) 00320 C 00321 IF (CDACTI.EQ.LFI%CNOMFI(IJ)) THEN 00322 INUMER=LFI%NUMERO(IJ) 00323 INLNOM=MIN0 (LFI%NLNOMF(IJ),LEN (CLMESS)-3) 00324 GOTO 132 00325 ENDIF 00326 C 00327 131 CONTINUE 00328 C 00329 132 CONTINUE 00330 CLMESS=' '''//CDACTI(1:INLNOM)//'''' 00331 WRITE (UNIT=LFI%NULOUT,FMT='(A)') CLMESS 00332 WRITE (UNIT=CLMESS,FMT='(''UNIT'',I3,'' - FILE ' 00333 ', S ''ALREADY OPEN WITH UNIT'',I3)') KNUMER,INUMER 00334 C 00335 ELSEIF (KCODE.EQ.-14) THEN 00336 C 00337 IF (CDNSPR.EQ.'LFIECR'.OR.CDNSPR.EQ.'LFILEC'.OR. 00338 S CDNSPR.EQ.'LFILAS'.OR.CDNSPR.EQ.'LFILAP') THEN 00339 WRITE (UNIT=CLMESS,FMT= 00340 S '(''INCORRECT RECORD LENGTH, UNIT'',I3)') KNUMER 00341 ELSEIF (KNUMER.EQ.LFI%JPNIL) THEN 00342 CLMESS='INCORRECT ENTRY IN *LFI%NUMERO* TABLE' 00343 ELSE 00344 WRITE (UNIT=CLMESS,FMT= 00345 S '(''INCORRECT INTEGER TYPE ARGUMENT, UNIT'',I3)') KNUMER 00346 ENDIF 00347 C 00348 ELSEIF (KCODE.EQ.-15) THEN 00349 WRITE (UNIT=CLMESS,FMT='(''RECORD NAME INCORRECT OR ' 00350 ', S ''TOO LONG, UNIT'',I3)') KNUMER 00351 C 00352 ELSEIF (KCODE.EQ.-16) THEN 00353 WRITE (UNIT=CLMESS,FMT='(''INCOHERENCE (TABLES, FILE, ' 00354 ', S ''INTERNAL CALLS, SOFTWARE), UNIT'',I3)') KNUMER 00355 C 00356 ELSEIF (KCODE.EQ.-17) THEN 00357 C 00358 IF (IJL.NE.0) THEN 00359 INBALO=LFI%MDES1D(IXM(LFI%JPNALO,IJL)) 00360 ELSE 00361 INBALO=LFI%JPNIL 00362 ENDIF 00363 C 00364 WRITE (UNIT=CLMESS, 00365 S FMT='(I6,'' RECORDS, INDEX FULL, UNIT' 00366 ', S I3)') INBALO,KNUMER 00367 C 00368 ELSEIF (KCODE.EQ.-18) THEN 00369 WRITE (UNIT=CLMESS,FMT='(''BLANK RECORD NAME IS INVALID' 00370 ', S '', UNIT'',I3)') KNUMER 00371 C 00372 ELSEIF (KCODE.EQ.-19) THEN 00373 WRITE (UNIT=CLMESS,FMT='(''UNIT' 00374 ',I3, S '' IS ''''SCRATCH'''', SO MAY NOT BE KEPT'')') KNUMER 00375 C 00376 ELSEIF (KCODE.EQ.-20) THEN 00377 WRITE (UNIT=CLMESS,FMT='(''RECORD "' 00378 ',A, S ''" NOT FOUND, UNIT'',I3)') CDACTI(1:ILACT2),KNUMER 00379 C 00380 ELSEIF (KCODE.EQ.-21) THEN 00381 WRITE (UNIT=CLMESS,FMT='(''RECORD "' 00382 ',A, S ''" *LONGER* THAN REQUESTED, UNIT'',I3)') 00383 S CDACTI(1:ILACT2),KNUMER 00384 C 00385 ELSEIF (KCODE.EQ.-22) THEN 00386 WRITE (UNIT=CLMESS,FMT='(''RECORD "' 00387 ',A, S ''" *SHORTER* THAN REQUESTED-UNIT'',I3)') 00388 S CDACTI(1:ILACT2),KNUMER 00389 C 00390 ELSEIF (KCODE.EQ.-23) THEN 00391 WRITE (UNIT=CLMESS,FMT='(''NO/NO MORE NEXT RECORD' 00392 ', S '' TO READ, UNIT'',I3)') KNUMER 00393 C 00394 ELSEIF (KCODE.EQ.-24) THEN 00395 WRITE (UNIT=CLMESS,FMT='(''CHARAC. VARIABLE TOO SHORT ' 00396 ', S ''FOR "'',A,''", UNIT'',I3)') 00397 S CDACTI(1:ILACT2),KNUMER 00398 C 00399 ELSEIF (KCODE.EQ.-25) THEN 00400 WRITE (UNIT=CLMESS,FMT='(''NEW RECORD NAME: "' 00401 ',A, S ''" ALREADY USED, UNIT'',I3)') 00402 S CDACTI(1:ILACT2),KNUMER 00403 C 00404 ELSEIF (KCODE.EQ.-26) THEN 00405 WRITE (UNIT=CLMESS,FMT='(''NO/NO MORE PREVIOUS RECORD ' 00406 ', S '' TO READ, UNIT'',I3)') KNUMER 00407 C 00408 ELSEIF (KCODE.EQ.-27) THEN 00409 WRITE (UNIT=CLMESS, 00410 S FMT='(''INSUFFICIENT CONTIGUOUS SPACE WI' 00411 ', S ''THIN TABLES, UNIT'',I3)') KNUMER 00412 C 00413 ELSEIF (KCODE.EQ.-28) THEN 00414 C 00415 IF (KNUMER.EQ.LFI%JPNIL) THEN 00416 WRITE (UNIT=CLMESS, 00417 S FMT='(''NEW DEFAULT MULTIPLY FACTOR EX' 00418 ', S ''CEEDS MAXIMUM ('',I3,'')'')') LFI%JPFACX 00419 ELSE 00420 WRITE (UNIT=CLMESS,FMT='(''SPECIFIED MULTIPLY FACTOR ' 00421 ', S ''EXCEEDS MAXIMUM ('',I3,''), UNIT'',I3)') LFI%JPFACX,KNUMER 00422 ENDIF 00423 C 00424 ELSEIF (KCODE.EQ.-29) THEN 00425 WRITE (UNIT=CLMESS,FMT='(I3,'' ENTRIES,' 00426 ', S '' NO MORE PLACE FOR MULTIPLY FACTOR, UNIT'',I3)') 00427 S LFI%JPXUFM,KNUMER 00428 C 00429 ELSEIF (KCODE.EQ.-30) THEN 00430 WRITE (UNIT=CLMESS,FMT='(''INVALID FORTRAN LOGICAL UNIT' 00431 ', S '' NUMBER:'',I8)') KNUMER 00432 C 00433 ELSEIF (KCODE.EQ.-31) THEN 00434 WRITE (UNIT=CLMESS,FMT='(''LOGICAL UNIT NUMBER' 00435 ',I3, S '' HAS NO PREDEFINED MULTIPLY FACTOR'')') KNUMER 00436 C 00437 C For unexpected error codes... 00438 C 00439 ELSEIF (KNUMER.EQ.LFI%JPNIL) THEN 00440 WRITE (UNIT=CLMESS,FMT='(''*UNKNOWN* GLOBAL ERROR CODE' 00441 ', S I6)') KCODE 00442 ELSE 00443 WRITE (UNIT=CLMESS,FMT='(''*UNKNOWN* ERROR CODE' 00444 ',I6, S '' ON LOGICAL UNIT'',I3)') KCODE,KNUMER 00445 ENDIF 00446 C 00447 ILMESA=LEN (CLMESA) 00448 ILMESU=ILMESA-1-2*LEN (CLJOLI)-ILNSPR-4 00449 CLMESA=CLJOLI//' '//CDNSPR(1:ILNSPR)//' - '// 00450 S CLMESS(1:ILMESU)//CLJOLI 00451 WRITE (UNIT=LFI%NULOUT,FMT='(A)') CLMESA 00452 C 00453 C If logical unit corresponds to a LFI logical unit 00454 C already opened, its name is printed. 00455 C 00456 IF (IJL.NE.0) THEN 00457 C 00458 IF (LFI%NLNOMF(IJL).LE.LFI%JPLFTX) THEN 00459 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') CLJOLI 00460 S //' NAME - APPEARENT BUT' 00461 S //' COMPLETE - OF LFI LOGICAL UNIT CONCERNED:' 00462 ELSE 00463 WRITE (UNIT=CLMESS,FMT= 00464 '(A, S '' NAME - APPEARENT, AND TRUNCATED BY' 00465 ',I4, S '' CARACTERES - OF LFI LOGICAL UNIT CONCERNED:'')') 00466 S CLJOLI,LFI%NLNOMF(IJL)-LFI%JPLFTX 00467 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') CLMESS 00468 ENDIF 00469 C 00470 INLIGN=(LFI%NLNOMF(IJL)-1)/LFI%JPLFIX 00471 IDECAL=0 00472 C 00473 DO 801 J=1,INLIGN 00474 WRITE (UNIT=LFI%NULOUT,FMT='(A)') 00475 S LFI%CNOMFI(IJL)(IDECAL+1:IDECAL+LFI%JPLFIX)//'...' 00476 IDECAL=IDECAL+LFI%JPLFIX 00477 801 CONTINUE 00478 C 00479 IF (LFI%NLNOMF(IJL).LE.LFI%JPLFTX) THEN 00480 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') 00481 S LFI%CNOMFI(IJL)(IDECAL+1:LFI%NLNOMF(IJL)) 00482 ELSE 00483 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') 00484 S LFI%CNOMFI(IJL)(IDECAL+1:LFI%JPLFTX) 00485 S //'...' 00486 ENDIF 00487 C 00488 IF (LFI%CNOMSY(IJL).NE.LFI%CNOMFI(IJL)) THEN 00489 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') CLJOLI// 00490 S ' *SYSTEM* NAME (APPEARENT) OF LFI LOGICAL UNIT CONCERNED:' 00491 INLIGN=(LFI%NLNOMS(IJL)-1)/LFI%JPLFIX 00492 IDECAL=0 00493 C 00494 DO 802 J=1,INLIGN 00495 WRITE (UNIT=LFI%NULOUT,FMT='(A)') 00496 S LFI%CNOMSY(IJL)(IDECAL+1:IDECAL+LFI%JPLFIX)//'...' 00497 IDECAL=IDECAL+LFI%JPLFIX 00498 802 CONTINUE 00499 C 00500 WRITE (UNIT=LFI%NULOUT,FMT='(A,/)') 00501 S LFI%CNOMSY(IJL)(IDECAL+1:LFI%NLNOMS(IJL)) 00502 ENDIF 00503 C 00504 ENDIF 00505 C 00506 WRITE (UNIT=LFI%NULOUT,FMT='(A)') CLMESA 00507 IF (LDFATA.AND.KCODE.NE.0) THEN 00508 C 00509 C Aborts program. 00510 C 00511 CALL SDL_SRLABORT 00512 ENDIF 00513 C 00514 ENDIF 00515 C 00516 IF (LHOOK) CALL DR_HOOK('LFIENG_MT',1,ZHOOK_HANDLE) 00517 END 00518
1.8.0
