From 5b62486bf7148270898ef0ece5c5bd112f47bd8b Mon Sep 17 00:00:00 2001 From: Pierre-Francois Loos Date: Wed, 14 Oct 2020 08:22:48 +0200 Subject: [PATCH] fix ninja --- Makefile | 1 - libxc-tools/install_libxc.sh | 21 +- src/make_ninja.py | 50 +++- src/utils/dfac.f | 508 ----------------------------------- 4 files changed, 62 insertions(+), 518 deletions(-) delete mode 100644 src/utils/dfac.f diff --git a/Makefile b/Makefile index b333b71..9605652 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,3 @@ default: make -C src - make -C qcaml-tools diff --git a/libxc-tools/install_libxc.sh b/libxc-tools/install_libxc.sh index c156d9c..42eb82f 100755 --- a/libxc-tools/install_libxc.sh +++ b/libxc-tools/install_libxc.sh @@ -1,9 +1,22 @@ #!/bin/bash +set -e -wget https://gitlab.com/libxc/libxc/-/archive/5.0.0/libxc-5.0.0.tar.gz -tar -xzf libxc-5.0.0.tar.gz -cd libxc-5.0.0 +: ${LIBXC_VERSION:=5.0.0} +: ${LXC:=libxc-${LIBXC_VERSION}} +: ${TARGZ:=${LXC}.tar.gz} + +if [[ $1 == "install" ]] ; then + make -C $LXC install + exit 0 +fi + +set -x +[[ -f $TARGZ ]] || wget https://gitlab.com/libxc/libxc/-/archive/${LIBXC_VERSION}/${TARGZ} +tar -xzf $TARGZ +cd $LXC +autoreconf -i ./configure --prefix=$QUACK_ROOT make -make check +#make check make install +set +x diff --git a/src/make_ninja.py b/src/make_ninja.py index 0d81747..7401973 100755 --- a/src/make_ninja.py +++ b/src/make_ninja.py @@ -52,6 +52,7 @@ LDIR=$QUACK_ROOT/lib BDIR=$QUACK_ROOT/bin SDIR=$QUACK_ROOT/src +LIBXC_VERSION=5.0.0 """.format(QUACK_ROOT) rule_fortran = """ @@ -97,18 +98,48 @@ rule make_numgrid pool = console build $LDIR/libnumgrid.a: make_numgrid + generator = true """ build_libxc = """ rule make_libxc - command = cd $QUACK_ROOT/libxc-tools ; QUACK_ROOT="$QUACK_ROOT" CC="$CC" CXX="$CXX" FC="$FC" ./install_libxc.sh + command = cd $QUACK_ROOT/libxc-tools ; LIBXC_VERSION="$LIBXC_VERSION" QUACK_ROOT="$QUACK_ROOT" CC="$CC" CXX="$CXX" FC="$FC" ./install_libxc.sh description = Building libxc pool = console -build $LDIR/libxc.a $LDIR/libxcf90.a $IDIR/xc.h $IDIR/xc_funcs_removed.h $IDIR/xc_f90_lib_m.mod $IDIR/xc_funcs_worker.h $IDIR/xc_funcs.h $IDIR/xc_version.h: make_libxc +rule install_libxc + command = cd $QUACK_ROOT/libxc-tools ; LIBXC_VERSION="$LIBXC_VERSION" QUACK_ROOT="$QUACK_ROOT" CC="$CC" CXX="$CXX" FC="$FC" ./install_libxc.sh install + description = Installing libxc + pool = console + +build $QUACK_ROOT/libxc-tools/libxc-$LIBXC_VERSION/src/.libs/libxcf90.a: make_libxc + generator = true + +build $LDIR/libxc.a $LDIR/libxcf90.a $IDIR/xc.h $IDIR/xc_funcs_removed.h $IDIR/xc_f90_lib_m.mod $IDIR/xc_funcs_worker.h $IDIR/xc_funcs.h $IDIR/xc_version.h: install_libxc $QUACK_ROOT/libxc-tools/libxc-$LIBXC_VERSION/src/.libs/libxcf90.a + generator = true """ +build_qcaml = """ +rule install_qcaml + command = cd $QUACK_ROOT/qcaml-tools ; ./install-qcaml.sh + pool = console + description = Installing QCaml + +build $QUACK_ROOT/qcaml-tools/qcaml/README.md: install_qcaml + generator = true +""" + +build_GoDuck = """ +rule make_goduck + command = cd $QUACK_ROOT/qcaml-tools ; make + pool = console + description = Compiling GoDuck + +build $QUACK_ROOT/GoDuck: make_goduck $QUACK_ROOT/qcaml-tools/qcaml/README.md +""" + + build_in_lib_dir = "\n".join([ header, compiler, @@ -131,6 +162,8 @@ build_main = "\n".join([ rule_git_clone, build_numgrid, build_libxc, + build_qcaml, + build_GoDuck, ]) exe_dirs = [ "QuAcK", "eDFT" ] @@ -195,11 +228,18 @@ rule build_lib """) for exe_dir in exe_dirs: - f.write("build $BDIR/{0}: build_exe {1} $LDIR/libnumgrid.a\n".format(exe_dir,libs)) + sources = [ "$SDIR/{0}/{1}".format(exe_dir,x) for x in os.listdir(exe_dir) ] + sources = filter(lambda x: x.endswith(".f") or x.endswith(".f90"), sources) + sources = " ".join(sources) + f.write("build $BDIR/{0}: build_exe {1} $LDIR/libnumgrid.a {2}\n".format(exe_dir,libs,sources)) f.write(" dir = {0} \n".format(exe_dir) ) + for libname in lib_dirs: - f.write("build $LDIR/{0}.a: build_lib\n dir = $SDIR/{0}\n".format(libname)) - f.write("build all: phony $BDIR/QuAcK $BDIR/eDFT\n") + sources = [ "$SDIR/{0}/{1}".format(libname,x) for x in os.listdir(libname) ] + sources = filter(lambda x: x.endswith(".f") or x.endswith(".f90"), sources) + sources = " ".join(sources) + f.write("build $LDIR/{0}.a: build_lib {1}\n dir = $SDIR/{0}\n".format(libname, sources)) + f.write("build all: phony $QUACK_ROOT/GoDuck $BDIR/QuAcK $BDIR/eDFT\n") f.write("default all\n") def create_makefile(directory): diff --git a/src/utils/dfac.f b/src/utils/dfac.f deleted file mode 100644 index 64cbb10..0000000 --- a/src/utils/dfac.f +++ /dev/null @@ -1,508 +0,0 @@ -*DECK DFAC - DOUBLE PRECISION FUNCTION DFAC (N) -C***BEGIN PROLOGUE DFAC -C***PURPOSE Compute the factorial function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C1 -C***TYPE DOUBLE PRECISION (FAC-S, DFAC-D) -C***KEYWORDS FACTORIAL, FNLIB, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C DFAC(N) calculates the double precision factorial for integer -C argument N. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D9LGMC, DGAMLM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DFAC - DOUBLE PRECISION FACN(31), SQ2PIL, X, XMAX, XMIN, D9LGMC - SAVE FACN, SQ2PIL, NMAX - DATA FACN ( 1) / +.1000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 2) / +.1000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 3) / +.2000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 4) / +.6000000000 0000000000 0000000000 000 D+1 / - DATA FACN ( 5) / +.2400000000 0000000000 0000000000 000 D+2 / - DATA FACN ( 6) / +.1200000000 0000000000 0000000000 000 D+3 / - DATA FACN ( 7) / +.7200000000 0000000000 0000000000 000 D+3 / - DATA FACN ( 8) / +.5040000000 0000000000 0000000000 000 D+4 / - DATA FACN ( 9) / +.4032000000 0000000000 0000000000 000 D+5 / - DATA FACN ( 10) / +.3628800000 0000000000 0000000000 000 D+6 / - DATA FACN ( 11) / +.3628800000 0000000000 0000000000 000 D+7 / - DATA FACN ( 12) / +.3991680000 0000000000 0000000000 000 D+8 / - DATA FACN ( 13) / +.4790016000 0000000000 0000000000 000 D+9 / - DATA FACN ( 14) / +.6227020800 0000000000 0000000000 000 D+10 / - DATA FACN ( 15) / +.8717829120 0000000000 0000000000 000 D+11 / - DATA FACN ( 16) / +.1307674368 0000000000 0000000000 000 D+13 / - DATA FACN ( 17) / +.2092278988 8000000000 0000000000 000 D+14 / - DATA FACN ( 18) / +.3556874280 9600000000 0000000000 000 D+15 / - DATA FACN ( 19) / +.6402373705 7280000000 0000000000 000 D+16 / - DATA FACN ( 20) / +.1216451004 0883200000 0000000000 000 D+18 / - DATA FACN ( 21) / +.2432902008 1766400000 0000000000 000 D+19 / - DATA FACN ( 22) / +.5109094217 1709440000 0000000000 000 D+20 / - DATA FACN ( 23) / +.1124000727 7776076800 0000000000 000 D+22 / - DATA FACN ( 24) / +.2585201673 8884976640 0000000000 000 D+23 / - DATA FACN ( 25) / +.6204484017 3323943936 0000000000 000 D+24 / - DATA FACN ( 26) / +.1551121004 3330985984 0000000000 000 D+26 / - DATA FACN ( 27) / +.4032914611 2660563558 4000000000 000 D+27 / - DATA FACN ( 28) / +.1088886945 0418352160 7680000000 000 D+29 / - DATA FACN ( 29) / +.3048883446 1171386050 1504000000 000 D+30 / - DATA FACN ( 30) / +.8841761993 7397019545 4361600000 000 D+31 / - DATA FACN ( 31) / +.2652528598 1219105863 6308480000 000 D+33 / - DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 / - DATA NMAX / 0 / -C***FIRST EXECUTABLE STATEMENT DFAC - IF (NMAX.NE.0) GO TO 10 - CALL DGAMLM (XMIN, XMAX) - NMAX = XMAX - 1.D0 -C - 10 IF (N .LT. 0) CALL XERMSG ('SLATEC', 'DFAC', - + 'FACTORIAL OF NEGATIVE INTEGER UNDEFINED', 1, 2) -C - IF (N.LE.30) DFAC = FACN(N+1) - IF (N.LE.30) RETURN -C - IF (N .GT. NMAX) CALL XERMSG ('SLATEC', 'DFAC', - + 'N SO BIG FACTORIAL(N) OVERFLOWS', 2, 2) -C - X = N + 1 - DFAC = EXP ((X-0.5D0)*LOG(X) - X + SQ2PIL + D9LGMC(X) ) -C - RETURN - END - - -*DECK DGAMLM - SUBROUTINE DGAMLM (XMIN, XMAX) -C***BEGIN PROLOGUE DGAMLM -C***PURPOSE Compute the minimum and maximum bounds for the argument in -C the Gamma function. -C***LIBRARY SLATEC (FNLIB) -C***CATEGORY C7A, R2 -C***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) -C***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS -C***AUTHOR Fullerton, W., (LANL) -C***DESCRIPTION -C -C Calculate the minimum and maximum legal bounds for X in gamma(X). -C XMIN and XMAX are not the only bounds, but they are the only non- -C trivial ones to calculate. -C -C Output Arguments -- -C XMIN double precision minimum legal value of X in gamma(X). Any -C smaller value of X might result in underflow. -C XMAX double precision maximum legal value of X in gamma(X). Any -C larger value of X might cause overflow. -C -C***REFERENCES (NONE) -C***ROUTINES CALLED D1MACH, XERMSG -C***REVISION HISTORY (YYMMDD) -C 770601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C***END PROLOGUE DGAMLM - DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH -C***FIRST EXECUTABLE STATEMENT DGAMLM - ALNSML = LOG(D1MACH(1)) - XMIN = -ALNSML - DO 10 I=1,10 - XOLD = XMIN - XLN = LOG(XMIN) - XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML) - 1 / (XMIN*XLN+0.5D0) - IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20 - 10 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2) -C - 20 XMIN = -XMIN + 0.01D0 -C - ALNBIG = LOG (D1MACH(2)) - XMAX = ALNBIG - DO 30 I=1,10 - XOLD = XMAX - XLN = LOG(XMAX) - XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG) - 1 / (XMAX*XLN-0.5D0) - IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40 - 30 CONTINUE - CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2) -C - 40 XMAX = XMAX - 0.01D0 - XMIN = MAX (XMIN, -XMAX+1.D0) -C - RETURN - END - - - -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END