C ALGORITHM 719, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 19, NO. 3, SEPTEMBER, 1993, PP. 286-317. README File for the Multiprecision Package and Translator Programs 32-bit computer version Update as of June 30, 1992 The following files are included in this "shar" file: Name Description mpfun.f MPFUN library file testmp.f Test program for MPFUN transmp.f TRANSMP program testran.f Test program for TRANSMP testran.out Reference output of test program These programs should work correctly on any 32-bit system, including those based on IEEE arithmetic. For Crays or other 64-bit systems, request separate versions of these programs from the author. On Unix systems, the following sequence compiles the MPFUN library; compiles, links and executes the test program for MPFUN; compiles the TRANSMP translator program; translates the test program for TRANSMP; compiles, links and executes the translated program; and compares the output of the translated program with the reference output file: Command Notes f77 -c mpfun.f Insert -O2 or -O3 after f77 for an optimized compile. There should be no fatal compiler diagnostics. f77 testmp.f mpfun.o There should be no fatal compiler diagnostics. a.out > testmp.out Check testmp.out to make sure all tests passed. f77 -o transmp transmp.f There should be no fatal compiler diagnostics. transmp < testran.f > tranout.f Check the end of tranout.f to make sure there are no fatal translator errors. f77 tranout.f mpfun.o There should be no fatal compiler diagnostics. a.out > tranout.out This should complete normally. diff tranout.out testran.out There should be no differences here. On IBM workstations, the four f77 lines should be replaced by xlf -O -c mpfun.f xlf testmp.f mpfun.o xlf -qrecur -qcharlen=1600 -o transmp transmp.f xlf tranout.f mpfun.o On HP workstations, comment out the two IMPLICIT AUTOMATIC statements in the transmp.f file before compiling. On DEC workstations, comment out these two lines and compile with the command f77 -automatic -o transmp transmp.f. These codes have been tested quite thoroughly, but a few bugs may remain. If you encounter any, please let me know and I will fix them as soon as possible. David H. Bailey NASA Ames Research Center Mail Stop T045-1 Moffett Field, CA 94035 Tel.: 415-604-4410 Fax: 415-604-3957 E-mail: dbailey@nas.nasa.gov 10 ^ 0 x 3.14159265358979323846264338327950288419716939937510582, 10 ^ 0 x 2.718281828459045235360287471352662497757247093699959574, 10 ^ 8 x 1.5929408, 10 ^ 14 x 1.52779903171104, 10 ^ 7 x 1.798869166210583847918164697465982392760106312722056703, 10 ^ 6 x 4.246554058540655594271278713230977821918624216872862863, 10 ^ 6 x 1.8734, 10 ^ 6 x 3.7468, 10 ^ 0 x 1.78661346435546875, 10 ^ 0 x 2.947257281471990863100813367572530600175591224440627617, 10 ^ 1 x 1.8, 10 ^ 1 x -2.492030753469781077845780729842283661121425243866422996, 10 ^ 0 x 0., C***************************************************************************** C C MPFUN: A MULTIPLE PRECISION FLOATING POINT COMPUTATION PACKAGE C C Standard version C Version Date: June 30, 1992 C C Author: C C David H. Bailey Telephone: 415-604-4410 C NASA Ames Research Center Facsimile: 415-604-3957 C Mail Stop T045-1 Internet: dbailey@nas.nasa.gov C Moffett Field, CA 94035 C USA C C Restrictions: C C This software has now been approved by NASA for unrestricted distribution. C However, usage of this software is subject to the following: C C 1. This software is offered without warranty of any kind, either expressed C or implied. The author would appreciate, however, any reports of bugs C or other difficulties that may be encountered. C 2. If modifications or enhancements to this software are made to this C software by others, NASA Ames reserves the right to obtain this enhanced C software at no cost and with no restrictions on its usage. C 3. The author and NASA Ames are to be acknowledged in any published paper C based on computations using this software. Accounts of practical C applications or other benefits resulting from this software are of C particular interest. Please send a copy of such papers to the author. C C Description: C C The following information is a brief description of this program. For C full details and instructions for usage, see the paper "A Portable High C Performance Multiprecision Package", available from the author. C C This package of Fortran subroutines performs multiprecision floating point C arithmetic. If sufficient main memory is available, the maximum precision C level is at least 16 million digits. The maximum dynamic range is at C least 10^(+-14,000,000). It employs advanced algorithms, including an C FFT-based multiplication routine and some recently discovered C quadratically convergent algorithms for pi, exp and log. The package also C features extensive debug and self-checking facilities, so that it can be C used as a rigorous system integrity test. All of the routines in this C package have been written to facilitate vector and parallel processing. C C For users who do not wish to manually write code that calls these routines, C an automatic translator program is available from the author that converts C ordinary Fortran-77 code into code that calls these routines. Contact the C author for details. C C This package should run correctly on any computer with a Fortran-77 C compiler that meets certain minimal floating point accuracy standards. C Any system based on the IEEE floating point standard, with a 25 bit C mantissa in single precision and a 53 bit mantissa in double precision, C easily meets these requirements. All DEC VAX systems meet these C requirements. All IBM mainframes and workstations meet these requirements. C Cray systems meet all of these requirements with double precision disabled C (i.e. by using only single precision). C C Machine-specific tuning notes may be located by searching for the text C string C> in this program file. It is highly recommended that these notes C be read before running this package on a specific system. If no comment C accompanies a C> string, this indicates that all references to INT in the C next loop may be safely changed to AINT. INT appears to be significantly C faster on many 32 bit systems, but AINT is slightly faster on Crays. Also, C certain vectorizable DO loops that are often not recognized as such by C vectorizing compilers are prefaced with Cray CDIR$ IVDEP directives. On C other vector systems these directives should be replaced by the C appropriate equivalents. C C Instructions for compiling and testing this program are included in the C readme file that accompanies this file. C C***************************************************************************** C BLOCK DATA C C This initializes the parameters in MPCOM1 and the error codes in MPCOM2 C with default values. C> C On IEEE systems and most other 32 bit systems, set BBXC = 4096.D0, C NBTC = 24, NPRC = 32, and MCRC = 7. On Cray systems, set BBXC = 2048.D0, C NBTC = 22, NPRC = 16, and MCRC = 8. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C PARAMETER (BBXC = 4096.D0, NBTC = 24, NPRC = 32, MCRC = 7, $ BDXC = BBXC ** 2, BX2C = BDXC ** 2, RBXC = 1.D0 / BBXC, $ RDXC = RBXC ** 2, RX2C = RDXC ** 2, RXXC = 16.D0 * RX2C) DATA BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR / BBXC, BDXC, $ BX2C, RBXC, RDXC, RX2C, RXXC, NBTC, NPRC/ DATA NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS / $ 16, 0, 6, 0, MCRC, 1, 1, 1, 1024/ DATA KER /72 * 2/ END C SUBROUTINE DPADD (A, NA, B, NB, C, NC) C C This adds the DPE numbers (A, NA) and (B, NB) to yield the sum (C, NC). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION PT(64) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS SAVE PT DATA PT/ 64 * 0.D0/ C IF (IER .NE. 0) THEN C = 0.D0 NC = 0 RETURN ENDIF C C If this is the first call to DPADD, initialize the PT table. C IF (PT(1) .EQ. 0.D0) THEN PT(1) = 0.5D0 C DO 100 I = 2, 64 PT(I) = 0.5D0 * PT(I-1) 100 CONTINUE C ENDIF C C This operation reduces to five cases. C IF (B .EQ. 0.D0) THEN C = A NC = NA ELSE IF (A .EQ. 0.D0) THEN C = B NC = NB ELSE IF (NA .EQ. NB) THEN C = A + B NC = NA ELSE IF (NA .GT. NB) THEN K = NA - NB NC = NA IF (K .GT. 64) THEN C = A ELSE C = A + B * PT(K) ENDIF ELSE K = NB - NA NC = NB IF (K .GT. 64) THEN C = B ELSE C = B + A * PT(K) ENDIF ENDIF IF (C .EQ. 0.D0) THEN NC = 0 GOTO 130 ENDIF C C Normalize the result to a decent range if it is not. C 110 IF (ABS (C) .GE. BDX) THEN C = RDX * C NC = NC + NBT GOTO 110 ENDIF C 120 IF (ABS (C) .LT. 1.D0) THEN C = BDX * C NC = NC - NBT GOTO 120 ENDIF C 130 RETURN END C SUBROUTINE DPDEC (A, NA, B, NB) C C This converts the DPE number (A, NA) to decimal form, i.e. B * 10^NB, C where |B| is between 1 and 10. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) PARAMETER (XLT = 0.3010299956639812D0) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (A .NE. 0.D0) THEN T1 = XLT * NA + LOG10 (ABS (A)) NB = T1 IF (T1 .LT. 0.D0) NB = NB - 1 B = SIGN (10.D0 ** (T1 - NB), A) ELSE B = 0.D0 NB = 0 ENDIF C RETURN END C SUBROUTINE DPDIV (A, NA, B, NB, C, NC) C C This divides the DPE number (A, NA) by (B, NB) to yield the quotient C (C, NC). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (IER .NE. 0) THEN C = 0.D0 NC = 0 RETURN ENDIF IF (B .EQ. 0.D0) THEN IF (KER(1) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** DPDIV: Divisor is zero.') IER = 1 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Divide A by B and subtract exponents, unless A is zero. C IF (A .EQ. 0.D0) THEN C = 0.D0 NC = 0 GOTO 120 ELSE C = A / B NC = NA - NB ENDIF C C Normalize the result to a decent range if it is not. C 100 IF (ABS (C) .GE. BDX) THEN C = RDX * C NC = NC + NBT GOTO 100 ENDIF C 110 IF (ABS (C) .LT. 1.D0) THEN C = BDX * C NC = NC - NBT GOTO 110 ENDIF C 120 RETURN END C SUBROUTINE DPMUL (A, NA, B, NB, C, NC) C C This multiplies the DPE number (A, NA) by (B, NB) to yield the product C (C, NC). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN C = 0.D0 NC = 0 RETURN ENDIF C C Multiply A by B and add exponents, unless either is zero. C IF (A .EQ. 0.D0 .OR. B .EQ. 0.D0) THEN C = 0.D0 NC = 0 GOTO 120 ELSE C = A * B NC = NA + NB ENDIF C C Normalize the result to a decent range if it is not. C 100 IF (ABS (C) .GE. BDX) THEN C = RDX * C NC = NC + NBT GOTO 100 ENDIF C 110 IF (ABS (C) .LT. 1.D0) THEN C = BDX * C NC = NC - NBT GOTO 110 ENDIF C 120 RETURN END C SUBROUTINE DPPWR (A, NA, B, NB, C, NC) C C This raises the DPE number (A, NA) to the (B, NB) power and places the C result in (C, NC). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) PARAMETER (CL2 = 1.4426950408889633D0) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (IER .NE. 0) THEN C = 0.D0 NC = 0 RETURN ENDIF IF (A .LE. 0.D0) THEN IF (KER(2) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** DPPWR: Argument is less than or equal to zero.') IER = 2 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C IF (B .EQ. 0.D0) THEN C = 1.D0 NC = 0 GOTO 120 ENDIF C IF (B .EQ. 1.D0 .AND. NB .EQ. 0) THEN C = A NC = NA GOTO 120 ENDIF C C Compute the base 2 logarithm of A and multiply by B. C AL = CL2 * LOG (A) + NA CALL DPMUL (AL, 0, B, NB, T1, N1) C C Check for possible overflow or underflow. C IF (N1 .GT. 6) THEN IF (T1 .GT. 0.D0) THEN IF (KER(3) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** DPPWR: Overflow') IER = 3 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ELSE C = 0.D0 NC = 0 GOTO 120 ENDIF ENDIF C C Compute 2 raised to the power B * Log_2 (A). C T1 = T1 * 2.D0 ** N1 NC = INT (T1) C = 2.D0 ** (T1 - NC) C C Normalize the result to a decent range if it is not. C 100 IF (ABS (C) .GE. BDX) THEN C = RDX * C NC = NC + NBT GOTO 100 ENDIF C 110 IF (ABS (C) .LT. 1.D0) THEN C = BDX * C NC = NC - NBT GOTO 110 ENDIF C 120 RETURN END C SUBROUTINE DPSQRT (A, NA, B, NB) C C This computes the square root of the DPE number (A, NA) and places the C result in (B, NB). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (IER .NE. 0) THEN B = 0.D0 NB = 0 RETURN ENDIF IF (A .LT. 0.D0) THEN IF (KER(4) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** DPSQRT: Argument is negative.') IER = 4 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C IF (A .EQ. 0.D0) THEN B = 0.D0 NB = 0 GOTO 120 ENDIF C C Divide the exponent of A by two and then take the square root of A. If C NA is not an even number, then we have to multiply A by 10 before taking C the square root. C NB = NA / 2 IF (NA .EQ. 2 * NB) THEN B = SQRT (A) ELSE B = SQRT (2.D0 * A) IF (NA .LT. 0) NB = NB - 1 ENDIF C C Normalize the result to a decent range if it is not. C 100 IF (ABS (B) .GE. BDX) THEN B = RDX * B NB = NB + NBT GOTO 100 ENDIF C 110 IF (ABS (B) .LT. 1.D0) THEN B = BDX * B NB = NB - NBT GOTO 110 ENDIF C 120 RETURN END C SUBROUTINE DPSUB (A, NA, B, NB, C, NC) C C This subtracts the DPE number (B, NB) from (A, NA) to yield the difference C (C, NC). C IMPLICIT DOUBLE PRECISION (A-H, O-Z) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN C = 0.D0 NC = 0 RETURN ENDIF C BB = -B CALL DPADD (A, NA, BB, NB, C, NC) C RETURN END C SUBROUTINE MPABRT C> C This routine terminates execution. Many users will want to replace the C default STOP with a call to a system routine that provides a traceback. C Examples of code that produce traceback are included here (commented out) C for some systems. C COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C WRITE (LDB, 1) IER 1 FORMAT ('*** MPABRT: Execution terminated, error code =',I4) C C Use this line on Cray systems. C C CALL ABORT C C Use this line plus the C routine TRACBK (available from author) on C Silicon Graphics IRIS systems. C C CALL TRACBK C C On other systems, merely terminate execution. C STOP END C SUBROUTINE MPADD (A, B, C) C C This routine adds MP numbers A and B to yield the MP sum C. It attempts C to include all significance of A and B in the result, up to the maximum C mantissa length NW. Debug output starts with IDB = 9. C C Max SP space for C: NW + 4 cells. Max DP scratch space: NW + 4 cells. C DOUBLE PRECISION D PARAMETER (NDB = 22) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM4/ D(1024) DIMENSION A(NW+2), B(NW+2), C(NW+4) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPADD I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF C IA = SIGN (1., A(1)) IB = SIGN (1., B(1)) NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) C C This first IF block checks for zero inputs. C IF (NA .EQ. 0) THEN C C A is zero -- the result is B. C C(1) = SIGN (NB, IB) C DO 100 I = 2, NB + 2 C(I) = B(I) 100 CONTINUE C GOTO 420 ELSEIF (NB .EQ. 0) THEN C C B is zero -- the result is A. C C(1) = SIGN (NA, IA) C DO 110 I = 1, NA + 2 C(I) = A(I) 110 CONTINUE C GOTO 420 ENDIF MA = A(2) MB = B(2) C C This IF block breaks the problem into different branches depending on C the relative sizes of the exponents of A and B. C IF (MA .EQ. MB) THEN C C A and B have the same exponent. C NM = MIN (NA, NB) NX = MAX (NA, NB) IF (IA .EQ. IB) THEN C C A and B have the same exponent and sign. C D(1) = SIGN (NX, IA) D(2) = MA D(NX+3) = 0.D0 D(NX+4) = 0.D0 C DO 120 I = 3, NM + 2 D(I) = DBLE (A(I)) + DBLE (B(I)) 120 CONTINUE C IF (NA .GT. NB) THEN C C A is longer than B -- include extra words of A in C. C DO 130 I = NM + 3, NA + 2 D(I) = A(I) 130 CONTINUE C ELSEIF (NB .GT. NA) THEN C C B is longer than A -- include extra words of B in C. C DO 140 I = NM + 3, NB + 2 D(I) = B(I) 140 CONTINUE C ENDIF ELSE C C A and B have the same exponent but the opposite sign. It is thus C necessary to scan through each vector until we find an unequal word. C DO 150 I = 3, NM + 2 IF (A(I) .NE. B(I)) GOTO 180 150 CONTINUE C C All words up to the common length are equal. C IF (NA .EQ. NB) THEN C C The length of A is the same as B -- result is zero. C C(1) = 0.D0 C(2) = 0.D0 GOTO 420 ELSEIF (NA .GT. NB) THEN C C A is longer -- thus trailing words of A are shifted to start of C. C NN = NA - NB D(1) = SIGN (NN, IA) D(2) = A(2) - NB D(NN+3) = 0.D0 D(NN+4) = 0.D0 C DO 160 I = 3, NN + 2 D(I) = A(I+NB) 160 CONTINUE C ELSEIF (NB .GT. NA) THEN C C B is longer -- thus trailing words of B are shifted to start of C. C NN = NB - NA D(1) = SIGN (NN, IB) D(2) = B(2) - NA D(NN+3) = 0.D0 D(NN+4) = 0.D0 C DO 170 I = 3, NN + 2 D(I) = B(I+NA) 170 CONTINUE C ENDIF GOTO 410 C C An unequal word was found. C 180 K = I - 3 IF (A(K+3) .GT. B(K+3)) THEN C C A is larger -- subtract B (shifted) from A. C D(1) = SIGN (NX - K, IA) D(2) = A(2) - K D(NX-K+3) = 0.D0 D(NX-K+4) = 0.D0 C DO 190 I = 3, NM - K + 2 D(I) = DBLE (A(I+K)) - DBLE (B(I+K)) 190 CONTINUE C DO 200 I = NB - K + 3, NA - K + 2 D(I) = A(I+K) 200 CONTINUE C DO 210 I = NA - K + 3, NB - K + 2 D(I) = - B(I+K) 210 CONTINUE C ELSE C C B is larger -- subtract A (shifted) from B. C D(1) = SIGN (NX - K, IB) D(2) = B(2) - K D(NX-K+3) = 0.D0 D(NX-K+4) = 0.D0 C DO 220 I = 3, NM - K + 2 D(I) = DBLE (B(I+K)) - DBLE (A(I+K)) 220 CONTINUE C DO 230 I = NB - K + 3, NA - K + 2 D(I) = - A(I+K) 230 CONTINUE C DO 240 I = NA - K + 3, NB - K + 2 D(I) = B(I+K) 240 CONTINUE C ENDIF ENDIF ELSEIF (MA .GT. MB) THEN C C Exponent of A is greater. In other words, A has a larger magnitude. C MC = MA - MB LA = MIN (MC, NA) LB = MIN (MC + NB, NW + 2) LM = MIN (NA, LB) LX = MIN (MAX (NA, LB), NW) D(1) = SIGN (LX, IA) D(2) = A(2) D(LX+3) = 0.D0 D(LX+4) = 0.D0 C DO 250 I = 3, LA + 2 D(I) = A(I) 250 CONTINUE C C If B is shifted NW + 2 or more words to the right of A then C = A. C IF (MC .GE. NW + 2) THEN D(1) = SIGN (NA, IA) GOTO 410 ENDIF IF (MC .GT. NA) THEN C C There is a gap between A and the shifted B. Fill it with zeroes. C DO 260 I = NA + 3, MC + 2 D(I) = 0.D0 260 CONTINUE C LM = MC ENDIF IF (IA .EQ. IB) THEN C C A and B have the same sign -- add common words with B shifted right. C DO 270 I = MC + 3, LM + 2 D(I) = DBLE (A(I)) + DBLE (B(I-MC)) 270 CONTINUE C C Include tail of A or B, whichever is longer after shift. C IF (NA .GT. LB) THEN C DO 280 I = LM + 3, NA + 2 D(I) = A(I) 280 CONTINUE C ELSE C DO 290 I = LM + 3, LB + 2 D(I) = B(I-MC) 290 CONTINUE C ENDIF ELSE C C A and B have different signs -- subtract common words with B shifted right. C DO 300 I = MC + 3, LM + 2 D(I) = DBLE (A(I)) - DBLE (B(I-MC)) 300 CONTINUE C C Include tail of A or B, whichever is longer after shift. C DO 310 I = LM + 3, NA + 2 D(I) = A(I) 310 CONTINUE C DO 320 I = LM + 3, LB + 2 D(I) = - B(I-MC) 320 CONTINUE C ENDIF ELSE C C Exponent of B is greater. In other words, B has a larger magnitude. C MC = MB - MA LB = MIN (MC, NB) LA = MIN (MC + NA, NW + 2) LM = MIN (NB, LA) LX = MIN (MAX (NB, LA), NW) D(1) = SIGN (LX, IB) D(2) = B(2) D(LX+3) = 0.D0 D(LX+4) = 0.D0 C DO 330 I = 3, LB + 2 D(I) = B(I) 330 CONTINUE C C If A is shifted NW + 2 or more words to the right of B then C = B. C IF (MC .GE. NW + 2) THEN D(1) = SIGN (NB, IB) GOTO 410 ENDIF IF (MC .GT. NB) THEN C C There is a gap between B and the shifted A. Fill it with zeroes. C DO 340 I = NB + 3, MC + 2 D(I) = 0.D0 340 CONTINUE C LM = MC ENDIF IF (IB .EQ. IA) THEN C C B and A have the same sign -- add common words with A shifted right. C DO 350 I = MC + 3, LM + 2 D(I) = DBLE (B(I)) + DBLE (A(I-MC)) 350 CONTINUE C C Include tail of B or A, whichever is longer after shift. C DO 360 I = LM + 3, NB + 2 D(I) = B(I) 360 CONTINUE C DO 370 I = LM + 3, LA + 2 D(I) = A(I-MC) 370 CONTINUE C ELSE C C B and A have different signs -- subtract common words with A shifted right. C DO 380 I = MC + 3, LM + 2 D(I) = DBLE (B(I)) - DBLE (A(I-MC)) 380 CONTINUE C C Include tail of B or A, whichever is longer after shift. C DO 390 I = LM + 3, NB + 2 D(I) = B(I) 390 CONTINUE C DO 400 I = LM + 3, LA + 2 D(I) = - A(I-MC) 400 CONTINUE C ENDIF ENDIF C C Fix up result, since some words may be negative or exceed BDX. C 410 CALL MPNORM (C) C 420 IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 2) (C(I), I = 1, NO) 2 FORMAT ('MPADD O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPAGMX (A, B) C C This performs the arithmetic-geometric mean (AGM) iterations. This routine C is called by MPLOGX. It is not intended to be called directly by the user. C C Max SP space for A and B: NW + 4 cells. Max SP scratch space: 5 * NW + 26 C cells. Max DP scratch space: 12 * NW + 6 cells. C COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) DIMENSION A(NW+4), B(NW+4) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. B(1) = 0. B(2) = 0. RETURN ENDIF N4 = NW + 4 NS = 2 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 S(K0) = 0. S(K0+1) = 0. L1 = 0 C 100 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(5) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPAGMX: Iteration limit exceeded.') IER = 5 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ENDIF C S1 = S(K0+1) CALL MPADD (A, B, S(K0)) CALL MPMULD (S(K0), 0.5D0, 0, S(K1)) CALL MPMULX (A, B, S(K0)) CALL MPSQRX (S(K0), B) CALL MPEQ (S(K1), A) CALL MPSUB (A, B, S(K0)) C C Check for convergence. C IF (S(K0) .NE. 0. .AND. (S(K0+1) .NE. S1 .OR. S(K0+1) .GE. -2)) $ GOTO 100 C ICS = ISS IF (IDB .GE. 6) WRITE (LDB, 2) L1, S(K0+1) 2 FORMAT ('MPAGMX: Iter., Tol. Achieved =',I5,F8.0) RETURN END C SUBROUTINE MPALER C C This outputs error messages when a single precision scratch space C allocation error is detected. C COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (KER(6) .NE. 0) THEN WRITE (LDB, 1) ICS - 1 1 FORMAT ('*** MPALER: Insufficient single precision scratch ', $ 'space.'/ 'Allocate',I10,' cells in an array in common ', $ 'MPCOM3 of the main '/ 'program and set IMS in common ', $ 'MPCOM1 to this size.') IER = 6 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF C RETURN END C SUBROUTINE MPANG (X, Y, PI, A) C C This computes the MP angle A subtended by the MP pair (X, Y) considered as C a point in the x-y plane. This is more useful than an arctan or arcsin C routine, since it places the result correctly in the full circle, i.e. C -Pi < A <= Pi. PI is the MP value of Pi computed by a previous call to C MPPI. For extra high levels of precision, use MPANGX. The last word of C the result is not reliable. Debug output starts with IDB = 5. C C Max SP space for A: NW + 4 cells. Max SP scratch space: 14 * NW + 81 C cells. Max DP scratch space: NW + 7 cells. C C The Taylor series for Sin converges much more slowly than that of Arcsin. C Thus this routine does not employ Taylor series, but instead computes C Arccos or Arcsin by solving Cos (a) = x or Sin (a) = y using one of the C following Newton iterations, both of which converge to a: C C z_{k+1} = z_k - [x - Cos (z_k)] / Sin (z_k) C z_{k+1} = z_k + [y - Sin (z_k)] / Cos (z_k) C C The first is selected if Abs (x) <= Abs (y); otherwise the second is used. C These iterations are performed with a maximum precision level NW that C is dynamically changed, approximately doubling with each iteration. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, CPI, T1, T2, T3 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, CPI = 3.141592653589793D0, $ NIT = 3) DIMENSION A(NW+4), PI(NW+2), X(NW+2), Y(NW+2) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF IF (IDB .GE. 5) THEN CALL MPDEB ('MPANG I', X) CALL MPDEB ('MPANG I', Y) ENDIF C IX = SIGN (1., X(1)) NX = MIN (INT (ABS (X(1))), NW) IY = SIGN (1., Y(1)) NY = MIN (INT (ABS (Y(1))), NW) C C Check if both X and Y are zero. C IF (NX .EQ. 0 .AND. NY .EQ. 0) THEN IF (KER(7) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPANG: Both arguments are zero.') IER = 7 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T1, N1) IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN IF (KER(8) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPANG: PI must be precomputed.') IER = 8 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if one of X or Y is zero. C IF (NX .EQ. 0) THEN IF (IY .GT. 0) THEN CALL MPMULD (PI, 0.5D0, 0, A) ELSE CALL MPMULD (PI, -0.5D0, 0, A) ENDIF GOTO 120 ELSEIF (NY .EQ. 0) THEN IF (IX .GT. 0) THEN A(1) = 0. A(2) = 0. ELSE CALL MPEQ (PI, A) ENDIF GOTO 120 ENDIF C N5 = NW + 5 NS = 5 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 K4 = K3 + N5 NWS = NW NW = NW + 1 C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NWS MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Normalize x and y so that x^2 + y^2 = 1. C CALL MPMUL (X, X, S(K0)) CALL MPMUL (Y, Y, S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPSQRT (S(K2), S(K3)) CALL MPDIV (X, S(K3), S(K1)) CALL MPDIV (Y, S(K3), S(K2)) C C Compute initial approximation of the angle. C CALL MPMDC (S(K1), T1, N1) CALL MPMDC (S(K2), T2, N2) N1 = MAX (N1, -66) N2 = MAX (N2, -66) T1 = T1 * 2.D0 ** N1 T2 = T2 * 2.D0 ** N2 T3 = ATAN2 (T2, T1) CALL MPDMC (T3, 0, A) C C The smaller of x or y will be used from now on to measure convergence. C This selects the Newton iteration (of the two listed above) that has the C largest denominator. C IF (ABS (T1) .LE. ABS (T2)) THEN KK = 1 CALL MPEQ (S(K1), S(K0)) ELSE KK = 2 CALL MPEQ (S(K2), S(K0)) ENDIF C NW = 3 IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (one greater than powers of two). C DO 110 K = 2, MQ NW = MIN (2 * NW - 2, NWS) + 1 100 CONTINUE CALL MPCSSN (A, PI, S(K1), S(K2)) IF (KK .EQ. 1) THEN CALL MPSUB (S(K0), S(K1), S(K3)) CALL MPDIV (S(K3), S(K2), S(K4)) CALL MPSUB (A, S(K4), S(K1)) ELSE CALL MPSUB (S(K0), S(K2), S(K3)) CALL MPDIV (S(K3), S(K1), S(K4)) CALL MPADD (A, S(K4), S(K1)) ENDIF CALL MPEQ (S(K1), A) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (A) C 120 IF (IDB .GE. 5) CALL MPDEB ('MPANG O', A) C RETURN END C SUBROUTINE MPANGX (X, Y, PI, A) C C This computes the MP angle A subtended by the MP pair (X, Y) considered as C a point in the x-y plane. This is more useful than an arctan or arcsin C routine, since it places the result correctly in the full circle, i.e. C -Pi < A <= Pi. PI is the MP value of Pi computed by a previous call to C MPPI or MPPIX. Before calling MPANGX, the array in MPCOM5 must be C initialized by calling MPINIX. For modest levels of precision, use MPANG. C NW should be a power of two. The last three words of the result are not C reliable. Debug output starts with IDB = 6. C C Max SP space for A: NW + 4 cells. Max SP scratch space: 18 * NW + 78 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs a complex arithmetic version of the MPLOGX alogirthm. C DOUBLE PRECISION CPI, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CPI = 3.141592653589793D0) DIMENSION A(NW+4), F0(8), F1(8), F4(8), PI(NW+2), X(NW+2), Y(NW+2) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN CALL MPDEB ('MPANGX I', X) CALL MPDEB ('MPANGX I', Y) ENDIF C IX = SIGN (1., X(1)) NX = MIN (INT (ABS (X(1))), NW) IY = SIGN (1., Y(1)) NY = MIN (INT (ABS (Y(1))), NW) NCR = 2 ** MCR C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPANG (X, Y, PI, A) GOTO 100 ENDIF C C Check if both X and Y are zero. C IF (NX .EQ. 0 .AND. NY .EQ. 0) THEN IF (KER(9) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPANGX: Both arguments are zero.') IER = 9 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T1, N1) IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN IF (KER(10) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPANGX: PI must be precomputed.') IER = 10 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if one of X or Y is zero. C IF (NX .EQ. 0) THEN IF (IY .GT. 0) THEN CALL MPMULD (PI, 0.5D0, 0, A) ELSE CALL MPMULD (PI, -0.5D0, 0, A) ENDIF GOTO 100 ELSEIF (NY .EQ. 0) THEN IF (IX .GT. 0) THEN A(1) = 0. A(2) = 0. ELSE CALL MPEQ (PI, A) ENDIF GOTO 100 ENDIF C C Define scratch space. C N4 = NW + 4 N42 = 2 * N4 NS = 4 * N42 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N42 K2 = K1 + N42 K3 = K2 + N42 F0(1) = 0. F0(2) = 0. F0(3) = 0. F1(1) = 1. F1(2) = 0. F1(3) = 1. F4(1) = 1. F4(2) = 0. F4(3) = 4. C C Multiply the input by a large power of two. C CALL MPMDC (X, T1, N1) N2 = NBT * (NW / 2 + 2) - N1 TN = N2 CALL MPMULD (X, 1.D0, N2, S(K1)) CALL MPMULD (Y, 1.D0, N2, S(K2)) CALL MPMMPC (S(K1), S(K2), N4, S(K0)) C C Perform AGM iterations. C CALL MPMMPC (F1, F0, N4, S(K1)) CALL MPMMPC (F4, F0, N4, S(K3)) CALL MPCDVX (N4, S(K3), S(K0), S(K2)) CALL MPCAGX (S(K1), S(K2)) C C Compute A = Imag (Pi / (2 * Z)), where Z is the limit of the complex AGM. C CALL MPMULD (S(K1), 2.D0, 0, S(K0)) CALL MPMULD (S(K1+N4), 2.D0, 0, S(K0+N4)) CALL MPMMPC (PI, F0, N4, S(K2)) CALL MPCDVX (N4, S(K2), S(K0), S(K1)) CALL MPEQ (S(K1+N4), A) ICS = ISS C 100 IF (IDB .GE. 6) CALL MPDEB ('MPANGX O', A) C RETURN END C SUBROUTINE MPCADD (L, A, B, C) C C This computes the sum of the MPC numbers A and B and returns the MPC C result in C. L is the offset between real and imaginary parts in A, B C and C. L must be at least NW + 4. Debug output starts with IDB = 9. C C Max SP space for C: 2 * L cells. C DIMENSION A(2*L), B(2*L), C(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF IF (IDB .GE. 9) WRITE (LDB, 1) 1 FORMAT ('MPCADD') C IF (L .LT. NW + 4) THEN IF (KER(11) .NE. 0) THEN WRITE (LDB, 2) L, NW + 4 2 FORMAT ('*** MPCADD: Offset parameter is too small',2I8) IER = 11 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C L1 = L + 1 CALL MPADD (A, B, C) CALL MPADD (A(L1), B(L1), C(L1)) C RETURN END C SUBROUTINE MPCAGX (A, B) C C This performs the arithmetic-geometric mean (AGM) iterations. This routine C is called by MPANGX. It is not intended to be called directly by the user. C C Max SP space for A and B: 2*NW + 8 cells. Max SP scratch space: 10*NW + 46 C cells. Max DP scratch space: 12 * NW + 6 cells. C COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) DIMENSION A(2*NW+8), B(2*NW+8) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. B(1) = 0. B(2) = 0. RETURN ENDIF N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + 2 * N4 S(K0) = 0. S(K0+1) = 0. L1 = 0 C 100 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(12) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPCAGX: Iteration limit exceeded.') IER = 12 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ENDIF C S1 = S(K0+1) CALL MPCADD (N4, A, B, S(K0)) CALL MPMULD (S(K0), 0.5D0, 0, S(K1)) CALL MPMULD (S(K0+N4), 0.5D0, 0, S(K1+N4)) CALL MPCMLX (N4, A, B, S(K0)) CALL MPCSQX (N4, S(K0), B) CALL MPCEQ (N4, S(K1), A) CALL MPSUB (A, B, S(K0)) C C Check for convergence. C IF (S(K0) .NE. 0. .AND. (S(K0+1) .NE. S1 .OR. S(K0+1) .GE. -2)) $ GOTO 100 C ICS = ISS IF (IDB .GE. 6) WRITE (LDB, 2) L1, S(K0+1) 2 FORMAT ('MPCAGX: Iter., Tol. Achieved =',I5,F8.0) RETURN END C SUBROUTINE MPCBRT (A, B) C C This computes the cube root of the MP number A and returns the MP result C in B. For extra high levels of precision, use MPCBRX. Debug output C starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 3 * NW + 15 C cells. Max DP scratch space: NW + 5 cells. C C This subroutine employs the following Newton-Raphson iteration, which C converges to A ^ (-2/3): C C X_{n+1} = X_k + (X_k / 3) * (1 - A^2 * X_k^3) C C Multiplying the final approximation to A ^ (-2/3) by A gives the cube C root. These iterations are performed with a maximum precision level NW that C is dynamically changed, approximately doubling with each iteration. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3) DIMENSION A(NW+2), B(NW+4), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPCBRT I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ENDIF IF (IA .LT. 0.D0) THEN IF (KER(13) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPCBRT: Argument is negative.') IER = 13 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N5 = NW + 5 NS = 3 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Compute A^2 outside of the iteration loop. C NW = NWS + 1 CALL MPMUL (A, A, S(K0)) C C Compute the initial approximation of A ^ (-2/3). C CALL MPMDC (A, T1, N) N3 = - 2 * N / 3 T2 = (T1 * 2.D0 ** (N + 3.D0 * N3 / 2.D0)) ** (-2.D0 / 3.D0) CALL MPDMC (T2, N3, B) F(1) = 1. F(2) = 0. F(3) = 1. NW = 3 IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (one greater than powers of two). C DO 110 K = 2, MQ NW = MIN (2 * NW - 2, NWS) + 1 100 CONTINUE CALL MPMUL (B, B, S(K1)) CALL MPMUL (B, S(K1), S(K2)) CALL MPMUL (S(K0), S(K2), S(K1)) CALL MPSUB (F, S(K1), S(K2)) CALL MPMUL (B, S(K2), S(K1)) CALL MPDIVD (S(K1), 3.D0, 0, S(K2)) CALL MPADD (B, S(K2), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Multiply by A to give final result. C CALL MPMUL (A, B, S(K1)) CALL MPEQ (S(K1), B) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) C 120 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPCBRT O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPCBRX (A, B) C C This computes the cube root of the MP number A and returns the MP result C in B. Before calling MPCBRX, the array in MPCOM5 must be initialized by C calling MPINIX. For modest levels of precision, use MPCBRT. NW should be C a power of two. The last three words of the result are not reliable. C Debug output starts with IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 4.5 * NW + 27 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses basically the same Newton iteration algorithm as MPCBRT. C In fact, this routine calls MPCBRT to obtain an initial approximation. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1) DIMENSION A(NW+2), B(NW+4), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPCBRX I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) NCR = 2 ** MCR C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ENDIF IF (IA .LT. 0.D0) THEN IF (KER(14) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPCBRX: Argument is negative.') IER = 14 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPCBRT (A, B) GOTO 120 ENDIF N4 = NW + 4 NS = 3 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Compute A^2 outside of the iteration loop. C CALL MPMULX (A, A, S(K0)) C C Compute the initial approximation of A ^ (-2/3). C NW = NCR CALL MPCBRT (A, S(K1)) CALL MPDIV (S(K1), A, B) F(1) = 1. F(2) = 0. F(3) = 1. IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (powers of two). C DO 110 K = MCR + 1, MQ AN = NW NW = MIN (2 * NW, NWS) 100 CONTINUE CALL MPMULX (B, B, S(K1)) CALL MPMULX (B, S(K1), S(K2)) CALL MPMULX (S(K0), S(K2), S(K1)) CALL MPSUB (F, S(K1), S(K2)) S(K2) = MIN (S(K2), AN) CALL MPMULX (B, S(K2), S(K1)) CALL MPDIVD (S(K1), 3.D0, 0, S(K2)) CALL MPADD (B, S(K2), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Multiply by A to give final result. C CALL MPMULX (A, B, S(K1)) CALL MPEQ (S(K1), B) ICS = ISS C 120 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPCBRX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPCDIV (L, A, B, C) C C This routine divides the MP complex numbers A and B to yield the MPC C quotient C. L is the offset between real and imaginary parts in A, B C and the result C. L must be at least NW + 4. For extra high levels of C precision, use MPCDVX. The last word is not reliable. Debug output C starts with IDB = 7 C C Max SP space for C: 2 * L cells. Max SP scratch space: 5 * NW + 20 C cells. Max DP scratch space: NW + 4 cells. C C This routine employs the formula described in MPCMUL to save multiprecision C multiplications. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L), C(2*L), F(8) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 7) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCDIV I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCDIV I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 2) (B(I), I = 1, NO) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 2) (B(L+I), I = 1, NO) ENDIF C IF (L .LT. NW + 4) THEN IF (KER(15) .NE. 0) THEN WRITE (LDB, 3) L, NW + 4 3 FORMAT ('*** MPCDIV: Offset parameter is too small',2I8) IER = 15 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C IF (B(1) .EQ. 0. .AND. B(L1) .EQ. 0.) THEN IF (KER(16) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPCDIV: Divisor is zero.') IER = 16 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 F(1) = 1. F(2) = 0. F(3) = 1. C CALL MPMUL (A, B, S(K0)) CALL MPMUL (A(L1), B(L1), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPSUB (S(K0), S(K1), S(K3)) CALL MPADD (A, A(L1), S(K0)) CALL MPSUB (B, B(L1), S(K1)) CALL MPMUL (S(K0), S(K1), S(K4)) CALL MPSUB (S(K4), S(K3), S(K1)) CALL MPMUL (B, B, S(K0)) CALL MPMUL (B(L1), B(L1), S(K3)) CALL MPADD (S(K0), S(K3), S(K4)) CALL MPDIV (F, S(K4), S(K0)) CALL MPMUL (S(K2), S(K0), C) CALL MPMUL (S(K1), S(K0), C(L1)) ICS = ISS C IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 5) (C(I), I = 1, NO) 5 FORMAT ('MPCDIV O'/(6F12.0)) NO = MIN (INT (ABS (C(L1))), NDB) + 2 WRITE (LDB, 5) (C(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCDVX (L, A, B, C) C C This routine divides the MP complex numbers A and B to yield the MPC C quotient C. L is the offset between real and imaginary parts in A, B C the result C. L must be at least NW + 4. Before calling MPCDVX, the C array in MPCOM5 must be initialized by calling MPINIX. For modest levels C of precision, use MPCDIV. NW should be a power of two. The last two C words are not reliable. Debug output starts with IDB = 7 C C Max SP space for C: 2 * L cells. Max SP scratch space: 7 * NW + 28 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs the same scheme as MPCDIV. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L), C(2*L), F(8) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 7) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCDVX I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCDVX I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 2) (B(I), I = 1, NO) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 2) (B(L+I), I = 1, NO) ENDIF C IF (L .LT. NW + 4) THEN IF (KER(17) .NE. 0) THEN WRITE (LDB, 3) L, NW + 4 3 FORMAT ('*** MPCDVX: Offset parameter is too small',2I8) IER = 17 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C IF (B(1) .EQ. 0. .AND. B(L1) .EQ. 0.) THEN IF (KER(18) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPCDVX: Divisor is zero.') IER = 18 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 F(1) = 1. F(2) = 0. F(3) = 1. C CALL MPMULX (A, B, S(K0)) CALL MPMULX (A(L1), B(L1), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPSUB (S(K0), S(K1), S(K3)) CALL MPADD (A, A(L1), S(K0)) CALL MPSUB (B, B(L1), S(K1)) CALL MPMULX (S(K0), S(K1), S(K4)) CALL MPSUB (S(K4), S(K3), S(K1)) CALL MPMULX (B, B, S(K0)) CALL MPMULX (B(L1), B(L1), S(K3)) CALL MPADD (S(K0), S(K3), S(K4)) CALL MPDIVX (F, S(K4), S(K0)) CALL MPMUL (S(K2), S(K0), C) CALL MPMUL (S(K1), S(K0), C(L1)) ICS = ISS C IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 5) (C(I), I = 1, NO) 5 FORMAT ('MPCDVX O'/(6F12.0)) NO = MIN (INT (ABS (C(L1))), NDB) + 2 WRITE (LDB, 5) (C(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCEQ (L, A, B) C C This sets the MPC number B equal to the MPC number A. L is the offset C between real and imaginary parts in A and B. Debug output starts with C IDB = 10. C C Max SP space for B: 2 * L cells. C DIMENSION A(2*L), B(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. RETURN ENDIF IF (IDB .GE. 10) WRITE (LDB, 1) 1 FORMAT ('MPCEQ') C I1 = SIGN (1., A(1)) N1 = MIN (INT (ABS (A(1))), NW, L - 2) I2 = SIGN (1., A(L+1)) N2 = MIN (INT (ABS (A(L+1))), NW, L - 2) B(1) = SIGN (N1, I1) B(L+1) = SIGN (N2, I2) C DO 100 I = 2, N1 + 2 B(I) = A(I) 100 CONTINUE C DO 110 I = 2, N2 + 2 B(L+I) = A(L+I) 110 CONTINUE C RETURN END C SUBROUTINE MPCFFT (IS, M, X, Y) C C This routine computes the 2^M -point complex-to-complex FFT of X. See C article by DHB in Intl. J. of Supercomputer Applications, Spring 1988, C p. 82 - 87). X and Y are double precision. X is both the input and the C output array, while Y is a scratch array. Both X and Y must be C dimensioned with 2 * N cells, where N = 2^M. The data in X are assumed C to have real and imaginary parts separated by N cells. A call to MPCFFT C with IS = 1 (or -1) indicates a call to perform a FFT with positive (or C negative) exponentials. M must be at least two. Before calling MPCRFT, C the array in MPCOM5 must be initialized by calling MPINIX. C C In this application, MPCFFT is called by MPRCFT and MPCRFT, which are in C turn called by MPMULX. This routine is not intended to be called directly C by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION X(*), Y(*) C N = 2 ** M C> C For Cray computers, it is most efficient to limit M1 to 6. For most C scalar computers, it is best to limit M1 to 2. Uncomment whichever of the C next two lines is appropriate. C C M1 = MIN (M / 2, 6) M1 = MIN (M / 2, 2) M2 = M - M1 N2 = 2 ** M1 N1 = 2 ** M2 C C Perform one variant of the Stockham FFT. C DO 100 L = 1, M1, 2 CALL MPFFT1 (IS, L, M, X, Y) IF (L .EQ. M1) GOTO 120 CALL MPFFT1 (IS, L + 1, M, Y, X) 100 CONTINUE C C Perform a transposition of X treated as a N2 x N1 x 2 matrix. C CALL MPTRAN (N1, N2, X, Y) C C Perform second variant of the Stockham FFT from Y to X and X to Y. C DO 110 L = M1 + 1, M, 2 CALL MPFFT2 (IS, L, M, Y, X) IF (L .EQ. M) GOTO 160 CALL MPFFT2 (IS, L + 1, M, X, Y) 110 CONTINUE C GOTO 140 C C Perform a transposition of Y treated as a N2 x N1 x 2 matrix. C 120 CALL MPTRAN (N1, N2, Y, X) C C Perform second variant of the Stockham FFT from X to Y and Y to X. C DO 130 L = M1 + 1, M, 2 CALL MPFFT2 (IS, L, M, X, Y) IF (L .EQ. M) GOTO 140 CALL MPFFT2 (IS, L + 1, M, Y, X) 130 CONTINUE C GOTO 160 C C Copy Y to X. C 140 DO 150 I = 1, 2 * N X(I) = Y(I) 150 CONTINUE C 160 RETURN END C SUBROUTINE MPCMLX (L, A, B, C) C C This routine multiplies the MP complex numbers A and B to yield the MPC C product C. L is the offset between real and imaginary parts in A, B and C the result C. L must be at least NW + 4. Before calling MPCMLX, the C array in MPCOM5 must be initialized by calling MPINIX. For modest levels C of precision, use MPCMUL. NW should be a power of two. The last word is C not reliable. Debug output starts with IDB = 7. C C Max SP space for C: 2 * L cells. Max SP scratch space: 4 * NW + 16 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs the same scheme as MPCMUL. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L), C(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 7) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCMLX I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCMLX I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 2) (B(I), I = 1, NO) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 2) (B(L+I), I = 1, NO) ENDIF C IF (L .LT. NW + 4) THEN IF (KER(19) .NE. 0) THEN WRITE (LDB, 3) L, NW + 4 3 FORMAT ('*** MPCMLX: Offset parameter is too small',2I8) IER = 19 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 C CALL MPMULX (A, B, S(K0)) CALL MPMULX (A(L1), B(L1), S(K1)) CALL MPSUB (S(K0), S(K1), C) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPADD (A, A(L1), S(K0)) CALL MPADD (B, B(L1), S(K1)) CALL MPMULX (S(K0), S(K1), S(K3)) CALL MPSUB (S(K3), S(K2), C(L1)) ICS = ISS C IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 4) (C(I), I = 1, NO) 4 FORMAT ('MPCMLX O'/(6F12.0)) NO = MIN (INT (ABS (C(L1))), NDB) + 2 WRITE (LDB, 4) (C(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCMUL (L, A, B, C) C C This routine multiplies the MP complex numbers A and B to yield the MPC C product C. L is the offset between real and imaginary parts in A, B and C the result C. L must be at least NW + 4. For extra high levels of C precision, use MPCMLX. The last word is not reliable. Debug output C starts with IDB = 7. C C Max SP space for C: 2 * L cells. Max SP scratch space: 4 * NW + 16 C cells. Max DP scratch space: NW + 4 cells. C C This routine employs the formula C C (a_1 + a_2 i) (b_1 + b_2 i) = [a_1 b_1 - a_2 b_2] + C [(a_1 + b_1) (a_2 + b_2) - (a_1 b_1 + a_2 b_2)] i C C Note that this formula can be implemented with only three multiplications C whereas the conventional formula requires four. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L), C(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE.7) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCMUL I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCMUL I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 2) (B(I), I = 1, NO) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 2) (B(L+I), I = 1, NO) ENDIF C IF (L .LT. NW + 4) THEN IF (KER(20) .NE. 0) THEN WRITE (LDB, 3) L, NW + 4 3 FORMAT ('*** MPCMUL: Offset parameter is too small',2I8) IER = 20 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 C CALL MPMUL (A, B, S(K0)) CALL MPMUL (A(L1), B(L1), S(K1)) CALL MPSUB (S(K0), S(K1), C) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPADD (A, A(L1), S(K0)) CALL MPADD (B, B(L1), S(K1)) CALL MPMUL (S(K0), S(K1), S(K3)) CALL MPSUB (S(K3), S(K2), C(L1)) ICS = ISS C IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 4) (C(I), I = 1, NO) 4 FORMAT ('MPCMUL O'/(6F12.0)) NO = MIN (INT (ABS (C(L1))), NDB) + 2 WRITE (LDB, 4) (C(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCPLX (N, LA, A, X1, NX, LX, X) C C This routine finds a complex root of the N-th degree polynomial whose C MPC coefficients are in A by Newton-Raphson iterations, beginning C at the complex DPE value (X1(1), NX(1)) + i (X1(2), NX(2)), and returns C the MPC root in X. The N + 1 coefficients a_0, a_1, ..., a_N are C assumed to start in locations A(1), A(2*LA+1), A(4*LA+1), etc. LA is the C offset between the real and the imaginary parts of each input coefficient. C Typically LA = NW + 4. LX, also an input parameter, is the offset between C the real and the imaginary parts of the result to be stored in X. LX C should be at least NW + 4. Before calling MPCPLX, the array in MPCOM5 C be initialized by calling MPINIX. For modest levels of precision, use C MPCPOL. NW should be a power of two. The last two words of the result C are not reliable. Debug output starts with IDB = 5. C C Max SP space for X: 2 * LX cells. Max SP scratch space: 17.5 * NW + 115 C cells. Max DP scratch space: 12 * NW + 6 cells. C C See the note in MPPOL about repeated roots. C C This routine employs the same scheme as MPCPOL. C CHARACTER*8 CX DOUBLE PRECISION T1, X1 DIMENSION A(2*LA,N+1), NX(2), X(2*LX), X1(2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. X(LX+1) = 0. X(LX+2) = 0. ENDIF IF (IDB .GE. 5) THEN WRITE (LDB, 1) N, LX 1 FORMAT ('MPCPLX I',2I6) C DO 100 K = 0, N WRITE (CX, '(I4)') K CALL MPDEB (CX, A(1,K+1)) CALL MPDEB (CX, A(LA+1,K+1)) 100 CONTINUE C WRITE (LDB, 2) X1(2), NX(2) 2 FORMAT ('MPCPLX I',F16.12,' x 10 ^',I6,F20.12,' x 10^',I6) ENDIF C C Check if precision level is too low to justify the advanced routine. C NCR = 2 ** MCR IF (NW .LE. NCR) THEN CALL MPCPOL (N, LA, A, X1, NX, LX, X) L1 = 0 GOTO 150 ENDIF C C Check if the polynomial is proper. C IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN IF (KER(21) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPCPLX: Either the first or last input ', $ 'coefficient is zero.') IER = 21 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 N8 = 2 * N4 NS = 10 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N8 K2 = K1 + N8 K3 = K2 + N8 K4 = K3 + N8 NWS = NW C C Set the initial value. C NW = NCR CALL MPCPOL (N, LA, A, X1, NX, N4, S(K0)) TL = -4. L1 = 0 LS = -10 C C Perform MP Newton-Raphson iterations to solve P(x) = 0. C 110 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(22) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPCPLX: Iteration limit exceeded.') IER = 22 IF (KER(IER) .EQ. 2) CALL MPABRT ICS = ISS NW = NWS RETURN ENDIF ENDIF C C Compute P(x). C CALL MPMMPC (A(1,N+1), A(LA+1,N+1), N4, S(K1)) C DO 120 K = N - 1, 0, -1 CALL MPCMLX (N4, S(K0), S(K1), S(K2)) CALL MPADD (S(K2), A(1,K+1), S(K1)) CALL MPADD (S(K2+N4), A(LA+1,K+1), S(K1+N4)) 120 CONTINUE C C Compute P'(x). C T1 = N CALL MPMULD (A(1,N+1), T1, 0, S(K2)) CALL MPMULD (A(LA+1,N+1), T1, 0, S(K2+N4)) C DO 130 K = N - 1, 1, -1 CALL MPCMLX (N4, S(K0), S(K2), S(K3)) T1 = K CALL MPMULD (A(1,K+1), T1, 0, S(K4)) CALL MPMULD (A(LA+1,K+1), T1, 0, S(K4+N4)) CALL MPCADD (N4, S(K3), S(K4), S(K2)) 130 CONTINUE C C Compute P(x) / P'(x) and update x. C CALL MPCDVX (N4, S(K1), S(K2), S(K3)) CALL MPCSUB (N4, S(K0), S(K3), S(K4)) C IF (IDB .GE. 6) THEN WRITE (LDB, 5) L1 5 FORMAT ('ITERATION',I4) CALL MPDEB ('X', S(K0)) CALL MPDEB (' ', S(K0+N4)) CALL MPDEB ('P(X)', S(K1)) CALL MPDEB (' ', S(K1+N4)) CALL MPDEB ('P''(X)', S(K2)) CALL MPDEB (' ', S(K2+N4)) CALL MPDEB ('CORR', S(K3)) CALL MPDEB (' ', S(K3+N4)) ENDIF CALL MPCEQ (N4, S(K4), S(K0)) C C If this was the second iteration at full precision, there is no need to C continue (the adjusted value of x is correct); otherwise repeat. C IF (L1 .EQ. LS + 1) GOTO 140 IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL .OR. S(K3+N4) .NE. 0. $ .AND. S(K3+N4+1) .GT. TL) GOTO 110 C C Newton iterations have converged to current precision. Increase precision C and continue. C IF (NW .EQ. NWS) GOTO 140 NW = MIN (2 * NW, NWS) IF (NW .EQ. NWS) LS = L1 IF (NW .LE. 32) THEN TL = 2 - NW ELSEIF (NW .LE. 256) THEN TL = 3 - NW ELSE TL = 4 - NW ENDIF IF (IDB .GE. 6) THEN WRITE (LDB, 6) NW 6 FORMAT (6X,'New NW =', I8) ENDIF GOTO 110 C 140 CALL MPMMPC (S(K0), S(K0+N4), LX, X) ICS = ISS C 150 IF (IDB .GE. 5) THEN WRITE (LDB, 7) L1 7 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPCPLX O', X) CALL MPDEB (' ', X(LX+1)) ENDIF RETURN END C SUBROUTINE MPCPOL (N, LA, A, X1, NX, LX, X) C C This routine finds a complex root of the N-th degree polynomial whose C MPC coefficients are in A by Newton-Raphson iterations, beginning C at the complex DPE value (X1(1), NX(1)) + i (X1(2), NX(2)), and returns C the MPC root in X. The N + 1 coefficients a_0, a_1, ..., a_N are C assumed to start in locations A(1), A(2*LA+1), A(4*LA+1), etc. LA is the C offset between the real and the imaginary parts of each input coefficient. C Typically LA = NW + 4. LX, also an input parameter, is the offset between C the real and the imaginary parts of the result to be stored in X. LX must C be at least NW + 4. For extra high levels of precision, use MPCPLX. C Debug output starts with IDB = 5. C C Max SP space for X: 2 * LX cells. Max SP scratch space: 15 * NW + 75 C cells. Max DP scratch space: NW + 5 cells. C C See the note about repeated roots in MPPOL. C C This routine employs the complex form of the Newton-Raphson iteration: C C X_{k+1} = X_k - P(X_k) / P'(X_k) C C These iterations are performed with a maximum precision level NW that is C dynamically changed, approximately doubling with each iteration. C CHARACTER*8 CX DOUBLE PRECISION T1, X1 DIMENSION A(2*LA,N+1), NX(2), X(2*LX), X1(2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. X(LX+1) = 0. X(LX+2) = 0. ENDIF IF (IDB .GE. 5) THEN WRITE (LDB, 1) N, LX 1 FORMAT ('MPCPOL I',2I6) C DO 100 K = 0, N WRITE (CX, '(I4)') K CALL MPDEB (CX, A(1,K+1)) CALL MPDEB (CX, A(LA+1,K+1)) 100 CONTINUE C WRITE (LDB, 2) X1(1), NX(1), X1(2), NX(2) 2 FORMAT ('MPCPOL I',F16.12,' x 10 ^',I6,F20.12,' x 10^',I6) ENDIF C C Check if the polynomial is proper. C IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN IF (KER(23) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPCPOL: Either the first or last input ', $ 'coefficient is zero.') IER = 23 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N5 = NW + 5 N10 = 2 * N5 NS = 10 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N10 K2 = K1 + N10 K3 = K2 + N10 K4 = K3 + N10 NWS = NW NW = NW + 1 C C Set the initial value. C CALL MPDMC (X1(1), NX(1), S(K0)) CALL MPDMC (X1(2), NX(2), S(K0+N5)) NW = 5 TL = -4. L1 = 0 LS = -10 C C Perform MP Newton-Raphson iterations to solve P(x) = 0. C 110 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(24) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPCPOL: Iteration limit exceeded.') IER = 24 IF (KER(IER) .EQ. 2) CALL MPABRT ICS = ISS NW = NWS RETURN ENDIF ENDIF C C Compute P(x). C CALL MPMMPC (A(1,N+1), A(LA+1,N+1), N5, S(K1)) C DO 120 K = N - 1, 0, -1 CALL MPCMUL (N5, S(K0), S(K1), S(K2)) CALL MPADD (S(K2), A(1,K+1), S(K1)) CALL MPADD (S(K2+N5), A(LA+1,K+1), S(K1+N5)) 120 CONTINUE C C Compute P'(x). C T1 = N CALL MPMULD (A(1,N+1), T1, 0, S(K2)) CALL MPMULD (A(LA+1,N+1), T1, 0, S(K2+N5)) C DO 130 K = N - 1, 1, -1 CALL MPCMUL (N5, S(K0), S(K2), S(K3)) T1 = K CALL MPMULD (A(1,K+1), T1, 0, S(K4)) CALL MPMULD (A(LA+1,K+1), T1, 0, S(K4+N5)) CALL MPCADD (N5, S(K3), S(K4), S(K2)) 130 CONTINUE C C Compute P(x) / P'(x) and update x. C CALL MPCDIV (N5, S(K1), S(K2), S(K3)) CALL MPCSUB (N5, S(K0), S(K3), S(K4)) C IF (IDB .GE. 6) THEN WRITE (LDB, 5) L1 5 FORMAT ('Iteration',I4) CALL MPDEB ('X', S(K0)) CALL MPDEB (' ', S(K0+N5)) CALL MPDEB ('P(X)', S(K1)) CALL MPDEB (' ', S(K1+N5)) CALL MPDEB ('P''(X)', S(K2)) CALL MPDEB (' ', S(K2+N5)) CALL MPDEB ('CORR', S(K3)) CALL MPDEB (' ', S(K3+N5)) ENDIF CALL MPCEQ (N5, S(K4), S(K0)) C C If this was the second iteration at full precision, there is no need to C continue (the adjusted value of x is correct); otherwise repeat. C IF (L1 .EQ. LS + 1) GOTO 140 IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL .OR. S(K3+N5) .NE. 0. $ .AND. S(K3+N5+1) .GT. TL) GOTO 110 C C Newton iterations have converged to current precision. Increase precision C and continue. C IF (NW .EQ. NWS + 1) GOTO 140 NW = MIN (2 * NW - 2, NWS) + 1 IF (NW .EQ. NWS + 1) LS = L1 TL = 1 - NW IF (IDB .GE. 6) THEN WRITE (LDB, 6) NW 6 FORMAT (6X,'New NW =', I8) ENDIF GOTO 110 C 140 CALL MPMMPC (S(K0), S(K0+N5), LX, X) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (X) CALL MPROUN (X(LX+1)) C IF (IDB .GE. 5) THEN WRITE (LDB, 7) L1 7 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPCPOL O', X) CALL MPDEB (' ', X(LX+1)) ENDIF RETURN END C SUBROUTINE MPCPR (A, B, IC) C C This routine compares the MP numbers A and B and returns in IC the value C -1, 0, or 1 depending on whether A < B, A = B, or A > B. It is faster C than merely subtracting A and B and looking at the sign of the result. C Debug output begins with IDB = 9. C DIMENSION A(NW+4), B(NW+4) PARAMETER (NDB = 22) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN IC = 0 RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPCPR I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF IA = SIGN (1., A(1)) IF (A(1) .EQ. 0.) IA = 0 IB = SIGN (1., B(1)) IF (B(1) .EQ. 0.) IB = 0 C C Compare signs. C IF (IA .NE. IB) THEN IC = SIGN (1, IA - IB) GOTO 110 ENDIF C C The signs are the same. Compare exponents. C MA = A(2) MB = B(2) IF (MA .NE. MB) THEN IC = IA * SIGN (1, MA - MB) GOTO 110 ENDIF C C The signs and the exponents are the same. Compare mantissas. C NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) C DO 100 I = 3, MIN (NA, NB) + 2 IF (A(I) .NE. B(I)) THEN IC = IA * SIGN (1., A(I) - B(I)) GOTO 110 ENDIF 100 CONTINUE C C The mantissas are the same to the common length. Compare lengths. C IF (NA .NE. NB) THEN IC = IA * SIGN (1, NA - NB) GOTO 110 ENDIF C C The signs, exponents, mantissas and lengths are the same. Thus A = B. C IC = 0 C 110 IF (IDB .GE. 9) WRITE (6, 2) IC 2 FORMAT ('MPCPR O',I4) RETURN END C SUBROUTINE MPCPWR (L, A, N, B) C C This computes the N-th power of the MPC number A and returns the MPC C result C in B. When N is zero, 1 is returned. When N is negative, the C reciprocal of A ^ |N| is returned. L is the offset between real and C imaginary parts in A and B. L should be at least NW + 4. For extra high C levels of precision, use MPCPWX. Debug output starts with IDB = 7. C C Max SP space for B: 2 * L cells. Max SP scratch space: 6 * NW + 30 C cells. Max DP scratch space: NW + 5 cells. C C This routine employs the binary method for exponentiation. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22) DIMENSION A(2*L), B(2*L), F1(8), F2(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 7) THEN WRITE (6, 1) L, N 1 FORMAT ('MPCPWR I',2I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCPWR I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) ENDIF C NA1 = MIN (INT (ABS (A(1))), NW) NA2 = MIN (INT (ABS (A(L1))), NW) IF (NA1 .EQ. 0 .AND. NA2 .EQ. 0) THEN IF (N .GE. 0) THEN B(1) = 0. B(2) = 0. B(L1) = 0. B(L1+1) = 0. GOTO 120 ELSE IF (KER(25) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPCPWR: Argument is zero and N is negative or', $ ' zero.') IER = 25 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C N5 = NW + 5 NS = 6 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + 2 * N5 K2 = K1 + 2 * N5 NWS = NW NW = NW + 1 NN = ABS (N) F1(1) = 1. F1(2) = 0. F1(3) = 1. F2(1) = 0. F2(2) = 0. CALL MPMMPC (A, A(L1), N5, S(K0)) IF (NN .EQ. 0) THEN CALL MPMMPC (F1, F2, L, B) NW = NWS ICS = ISS GOTO 120 ELSEIF (NN .EQ. 1) THEN CALL MPCEQ (N5, S(K0), S(K2)) GOTO 110 ELSEIF (NN .EQ. 2) THEN CALL MPCMUL (N5, S(K0), S(K0), S(K2)) GOTO 110 ENDIF C C Determine the least integer MN such that 2 ^ MN .GT. NN. C T1 = NN MN = CL2 * LOG (T1) + 1.D0 + RXX CALL MPMMPC (F1, F2, N5, S(K2)) KN = NN C C Compute B ^ N using the binary rule for exponentiation. C DO 100 J = 1, MN KK = KN / 2 IF (KN .NE. 2 * KK) THEN CALL MPCMUL (N5, S(K2), S(K0), S(K1)) CALL MPCEQ (N5, S(K1), S(K2)) ENDIF KN = KK IF (J .LT. MN) THEN CALL MPCMUL (N5, S(K0), S(K0), S(K1)) CALL MPCEQ (N5, S(K1), S(K0)) ENDIF 100 CONTINUE C C Compute reciprocal if N is negative. C 110 IF (N .LT. 0) THEN CALL MPMMPC (F1, F2, N5, S(K1)) CALL MPCDIV (N5, S(K1), S(K2), S(K0)) CALL MPCEQ (N5, S(K0), S(K2)) ENDIF CALL MPMMPC (S(K2), S(N5+K2), L, B) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) CALL MPROUN (B(L1)) C 120 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 4) (B(I), I = 1, NO) 4 FORMAT ('MPCPWR O'/(6F12.0)) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 4) (B(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCPWX (L, A, N, B) C C This computes the N-th power of the MPC number A and returns the MPC C result C in B. When N is zero, 1 is returned. When N is negative, the C reciprocal of A ^ |N| is returned. L is the offset between real and C imaginary parts in A and B. L should be at least NW + 4. Before calling C MPCPWX, the array in MPCOM5 must be initialized by calling MPINIX. For C modest levels of precision, use MPCPWR. NW should be a power of two. C The last two words of the result are not reliable. Debug output starts C with IDB = 6. C C Max SP space for B: 2 * L cells. Max SP scratch space: 8 * NW + 32 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs the binary method for exponentiation. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22) DIMENSION A(2*L), B(2*L), F1(8), F2(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 6) THEN WRITE (6, 1) L, N 1 FORMAT ('MPCPWX I',2I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCPWX I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) ENDIF C NA1 = MIN (INT (ABS (A(1))), NW) NA2 = MIN (INT (ABS (A(L1))), NW) NCR = 2 ** MCR C C Check if precision level of A is too low to justify advanced routine. C IF (NA1 .LE. NCR .AND. NA2 .LE. NCR) THEN CALL MPCPWR (L, A, N, B) GOTO 120 ENDIF IF (NA1 .EQ. 0 .AND. NA2 .EQ. 0) THEN IF (N .GE. 0) THEN B(1) = 0. B(2) = 0. B(L1) = 0. B(L1+1) = 0. GOTO 120 ELSE IF (KER(26) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPCPWX: Argument is zero and N is negative or', $ ' zero.') IER = 26 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C N4 = NW + 4 NS = 6 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + 2 * N4 K2 = K1 + 2 * N4 NN = ABS (N) F1(1) = 1. F1(2) = 0. F1(3) = 1. F2(1) = 0. F2(2) = 0. CALL MPMMPC (A, A(L1), N4, S(K0)) IF (NN .EQ. 0) THEN CALL MPMMPC (F1, F2, L, B) ICS = ISS GOTO 120 ELSEIF (NN .EQ. 1) THEN CALL MPCEQ (N4, S(K0), S(K2)) GOTO 110 ELSEIF (NN .EQ. 2) THEN CALL MPCMLX (N4, S(K0), S(K0), S(K2)) GOTO 110 ENDIF C C Determine the least integer MN such that 2 ^ MN .GT. NN. C T1 = NN MN = CL2 * LOG (T1) + 1.D0 + RXX CALL MPMMPC (F1, F2, N4, S(K2)) KN = NN C C Compute B ^ N using the binary rule for exponentiation. C DO 100 J = 1, MN KK = KN / 2 IF (KN .NE. 2 * KK) THEN CALL MPCMLX (N4, S(K2), S(K0), S(K1)) CALL MPCEQ (N4, S(K1), S(K2)) ENDIF KN = KK IF (J .LT. MN) THEN CALL MPCMLX (N4, S(K0), S(K0), S(K1)) CALL MPCEQ (N4, S(K1), S(K0)) ENDIF 100 CONTINUE C C Compute reciprocal if N is negative. C 110 IF (N .LT. 0) THEN CALL MPMMPC (F1, F2, N4, S(K1)) CALL MPCDVX (N4, S(K1), S(K2), S(K0)) CALL MPCEQ (N4, S(K0), S(K2)) ENDIF CALL MPMMPC (S(K2), S(N4+K2), L, B) ICS = ISS C 120 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 4) (B(I), I = 1, NO) 4 FORMAT ('MPCPWX O'/(6F12.0)) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 4) (B(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCRFT (IS, M, X, Y) C C This performs an N-point complex-to-real FFT, where N = 2^M. X and Y C are double precision arrays. X is both the input and the output data C array, and Y is a scratch array. N/2 + 1 complex pairs are input, with C real and imaginary parts separated by N/2 + 1 locations, and N real C values are output . A call to MPCRFT with IS = 1 (or -1) indicates a call C to perform a complex-to-real FFT with positive (or negative) exponentials. C M must be at least three. The arrays X and Y must be dimensioned with C N + 2 cells. Before calling MPCRFT, the U array in MPCOM5 must be C initialized by calling MPINIX. C C In this application, MPCRFT is called by MPMULX. This routine is not C intended to be called directly by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION X(*), Y(*) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM5/ U(1024) C C Set initial parameters. C K = U(1) MX = MOD (K, 64) NU = K / 64 N = 2 ** M N2 = N / 2 N21 = N2 + 1 N4 = N / 4 KU = N / 2 KN = KU + NU C C Check if input parameters are invalid. C IF ((IS .NE. 1 .AND. IS .NE. -1) .OR. M .LT. 3 .OR. M .GT. MX) $ THEN IF (KER(27) .NE. 0) THEN WRITE (LDB, 1) IS, M, MX 1 FORMAT ('*** MPCRFT: Either U has not been initialized'/ $ 'or else one of the input parameters is invalid', 3I5) IER = 27 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Construct the input to MPCFFT. C Y(1) = 0.5D0 * (X(1) + X(N21)) Y(N2+1) = 0.5D0 * (X(1) - X(N21)) Y(N4+1) = X(N4+1) Y(N4+N2+1) = -IS * X(N4+N2+2) C CDIR$ IVDEP DO 100 K = 2, N4 X11 = X(K) X12 = X(K+N21) X21 = X(N2+2-K) X22 = X(N+3-K) A1 = X11 + X21 A2 = X11 - X21 B1 = X12 + X22 B2 = X12 - X22 U1 = U(K+KU) U2 = IS * U(K+KN) T1 = U1 * B1 + U2 * A2 T2 = U1 * A2 - U2 * B1 Y(K) = 0.5D0 * (A1 - T1) Y(K+N2) = 0.5D0 * (B2 + T2) Y(N2+2-K) = 0.5D0 * (A1 + T1) Y(N+2-K) = 0.5D0 * (-B2 + T2) 100 CONTINUE C C Perform a normal N/2-point FFT on Y. C CALL MPCFFT (IS, M - 1, Y, X) C C Copy Y to X such that Y(k) = X(2k-1) + i X(2k). C CDIR$ IVDEP DO 110 K = 1, N2 X(2*K-1) = Y(K) X(2*K) = Y(K+N2) 110 CONTINUE C RETURN END C SUBROUTINE MPCSHX (A, PI, AL2, X, Y) C C This computes the hyperbolic cosine and sine of the MP number A and C returns the two MP results in X and Y, respectively. PI is the MP value C of Pi computed by a previous call to MPPI or MPPIX. AL2 is the MP value C of Log (10) computed by a previous call to MPLOG or MPLOGX. Before C calling MPCSHX, the array in MPCOM5 must be initialized by calling MPINIX. C For modest levels of precision, use MPCSSH. NW should be a power of two. C The last four words of the result are not reliable. Debug output starts C with IDB = 5. C C Max SP space for X and Y: NW + 4 cells. Max SP scratch space: C 28 * NW + 132 cells. Max DP scratch space: 12 * NX + 6 cells. C DIMENSION A(NW+2), F(8), AL2(NW+2), PI(NW+2), X(NW+4), Y(NW+4) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. Y(1) = 0. Y(2) = 0. RETURN ENDIF IF (IDB .GE. 5) CALL MPDEB ('MPCSHX I', A) C N4 = NW + 4 NS = 3 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 F(1) = 1. F(2) = 0. F(3) = 1. C CALL MPEXPX (A, PI, AL2, S(K0)) CALL MPDIVX (F, S(K0), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, X) CALL MPSUB (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, Y) ICS = ISS C IF (IDB .GE. 5) THEN CALL MPDEB ('MPCSHX O', X) CALL MPDEB ('MPCSHX O', Y) ENDIF RETURN END C SUBROUTINE MPCSQR (L, A, B) C C This routine computes the complex square root of the MPC number C. L is C the offset between real and imaginary parts in A and B. L must be at C least NW + 4. For extra high levels of precision, use MPCSQX. The last C word is not reliable. Debug output starts with IDB = 6. C C Max SP space for B: 2 * L cells. Max SP scratch space: 5 * NW + 22 C cells. Max DP scratch space: NW + 5 cells. C C This routine uses the following formula, where A1 and A2 are the real and C imaginary parts of A, and where R = Sqrt [A1 ^ 2 + A2 ^2]: C C B = Sqrt [(R + A1) / 2] + I Sqrt [(R - A1) / 2] C C If the imaginary part of A is < 0, then the imaginary part of B is also C set to be < 0. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 6) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCSQR I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCSQR I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) ENDIF C IF (A(1) .EQ. 0. .AND. A(L+1) .EQ. 0.) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. GOTO 100 ENDIF C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 C CALL MPMUL (A, A, S(K0)) CALL MPMUL (A(L1), A(L1), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPSQRT (S(K2), S(K0)) CALL MPEQ (A, S(K1)) S(K1) = ABS (S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K1)) CALL MPSQRT (S(K1), S(K0)) CALL MPMULD (S(K0), 2.D0, 0, S(K1)) IF (A(1) .GE. 0.) THEN CALL MPEQ (S(K0), B) CALL MPDIV (A(L1), S(K1), B(L1)) ELSE CALL MPDIV (A(L1), S(K1), B) B(1) = ABS (B(1)) CALL MPEQ (S(K0), B(L1)) B(L1) = SIGN (B(L1), A(L1)) ENDIF ICS = ISS C 100 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPCSQR O'/(6F12.0)) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 3) (B(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCSQX (L, A, B) C C This routine computes the complex square root of the MPC number C. L is C the offset between real and imaginary parts in A and B. L must be at C least NW + 4. For modest levels of precision, use MPCSQR. The last two C words are not reliable. Debug output starts with IDB = 5. C C Max SP space for B: 2 * L cells. Max SP scratch space: 6 * NW + 30. C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses the same algorithm as MPCSQR. C PARAMETER (NDB = 22) DIMENSION A(2*L), B(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. RETURN ENDIF L1 = L + 1 IF (IDB .GE. 5) THEN WRITE (LDB, 1) L 1 FORMAT ('MPCSQX I',I10) NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPCSQX I'/(6F12.0)) NO = MIN (INT (ABS (A(L1))), NDB) + 2 WRITE (LDB, 2) (A(L+I), I = 1, NO) ENDIF C IF (A(1) .EQ. 0. .AND. A(L+1) .EQ. 0.) THEN B(1) = 0. B(2) = 0. B(L+1) = 0. B(L+2) = 0. GOTO 100 ENDIF C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IF (ICS - 1 .GT. IMS) CALL MPALER IHS = MAX (ICS, IHS) K0 = ISS K1 = K0 + N4 K2 = K1 + N4 C CALL MPMULX (A, A, S(K0)) CALL MPMULX (A(L1), A(L1), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPSQRX (S(K2), S(K0)) CALL MPEQ (A, S(K1)) S(K1) = ABS (S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K1)) CALL MPSQRX (S(K1), S(K0)) CALL MPMULD (S(K0), 2.D0, 0, S(K1)) IF (A(1) .GE. 0.) THEN CALL MPEQ (S(K0), B) CALL MPDIVX (A(L1), S(K1), B(L1)) ELSE CALL MPDIVX (A(L1), S(K1), B) B(1) = ABS (B(1)) CALL MPEQ (S(K0), B(L1)) B(L1) = SIGN (B(L1), A(L1)) ENDIF ICS = ISS C 100 IF (IDB .GE. 5) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPCSQX O'/(6F12.0)) NO = MIN (INT (ABS (B(L1))), NDB) + 2 WRITE (LDB, 3) (B(L+I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPCSSH (A, AL2, X, Y) C C This computes the hyperbolic cosine and sine of the MP number A and C returns the two MP results in X and Y, respectively. AL2 is the MP value C of Log (10) computed by a previous call to MPLOG. For extra high levels of C precision, use MPCSHX. The last word of the result is not reliable. C Debug output starts with IDB = 5. C C Max SP space for X and Y: NW + 4 cells. Max SP scratch space: 9 * NW + 50 C cells. Max DP scratch space: NW + 6 cells. C DIMENSION A(NW+2), F(8), AL2(NW+2), X(NW+4), Y(NW+4) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. Y(1) = 0. Y(2) = 0. RETURN ENDIF IF (IDB .GE. 5) CALL MPDEB ('MPCSSH I', A) C N5 = NW + 5 NS = 4 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 NWS = NW NW = NW + 1 F(1) = 1. F(2) = 0. F(3) = 1. C CALL MPEXP (A, AL2, S(K0)) CALL MPDIV (F, S(K0), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K3)) CALL MPEQ (S(K3), X) CALL MPSUB (S(K0), S(K1), S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K3)) CALL MPEQ (S(K3), Y) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (X) CALL MPROUN (Y) C IF (IDB .GE. 5) THEN CALL MPDEB ('MPCSSH O', X) CALL MPDEB ('MPCSSH O', Y) ENDIF RETURN END C SUBROUTINE MPCSSN (A, PI, X, Y) C C This computes the cosine and sine of the MP number A and returns the two MP C results in X and Y, respectively. PI is the MP value of Pi computed by a C previous call to MPPI. For extra high levels of precision, use MPCSSX. C The last word of the result is not reliable. Debug output starts with C IDB = 6. C C Max SP space for X and Y: NW + 4 cells. Max SP scratch space: 9 * NW + 47 C cells. Max DP scratch space: NW + 6 cells. C C This routine uses the conventional Taylor's series for Sin (s): C C Sin (s) = s - s^3 / 3! + s^5 / 5! - s^7 / 7! ... C C where s = t - a * pi / 2 - b * pi / 16 and the integers a and b are chosen C to minimize the absolute value of s. We can then compute C C Sin (t) = Sin (s + a * pi / 2 + b * pi / 16) C Cos (t) = Cos (s + a * pi / 2 + b * pi / 16) C C by applying elementary trig identities for sums. The sine and cosine of C b * pi / 16 are of the form 1/2 * Sqrt {2 +- Sqrt [2 +- Sqrt(2)]}. C Reducing t in this manner insures that -Pi / 32 < s <= Pi / 32, which C accelerates convergence in the above series. C DOUBLE PRECISION CPI, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CPI = 3.141592653589793D0) DIMENSION A(NW+2), F(8), PI(NW+2), X(NW+4), Y(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. Y(1) = 0. Y(2) = 0. RETURN ENDIF IF (IDB .GE. 6) CALL MPDEB ('MPCSSN I', A) C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) IF (NA .EQ. 0) THEN X(1) = 1. X(2) = 0. X(3) = 1. Y(1) = 0. Y(2) = 0. L1 = 0 GOTO 120 ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T1, N1) IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN IF (KER(28) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPCSSN: PI must be precomputed.') IER = 28 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N5 = NW + 5 NS = 7 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 K4 = K3 + N5 K5 = K4 + N5 K6 = K5 + N5 NWS = NW NW = NW + 1 F(1) = 1. F(2) = 0. F(3) = 1. C C Reduce to between - Pi and Pi. C CALL MPMULD (PI, 2.D0, 0, S(K0)) CALL MPDIV (A, S(K0), S(K1)) CALL MPNINT (S(K1), S(K2)) CALL MPSUB (S(K1), S(K2), S(K3)) C C Determine nearest multiple of Pi / 2, and within a quadrant, the nearest C multiple of Pi / 16. Through most of the rest of this subroutine, KA and C KB are the integers a and b of the algorithm above. C CALL MPMDC (S(K3), T1, N1) IF (N1 .GE. -24) THEN T1 = T1 * 2.D0 ** N1 T2 = 4.D0 * T1 KA = NINT (T2) KB = NINT (8.D0 * (T2 - KA)) ELSE KA = 0 KB = 0 ENDIF T1 = (8 * KA + KB) / 32.D0 CALL MPDMC (T1, 0, S(K1)) CALL MPSUB (S(K3), S(K1), S(K2)) CALL MPMUL (S(K0), S(K2), S(K1)) C C Compute cosine and sine of the reduced argument s using Taylor's series. C IF (S(K1) .EQ. 0.) THEN S(K0) = 0. S(K0+1) = 0. L1 = 0 GOTO 110 ENDIF CALL MPEQ (S(K1), S(K0)) CALL MPMUL (S(K0), S(K0), S(K2)) L1 = 0 C 100 L1 = L1 + 1 IF (L1 .EQ. 10000) THEN IF (KER(29) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPCSSN: Iteration limit exceeded.') IER = 29 IF (KER(IER) .EQ. 2) CALL MPABRT ICS = ISS NW = NWS RETURN ENDIF ENDIF C T2 = - (2.D0 * L1) * (2.D0 * L1 + 1.D0) CALL MPMUL (S(K2), S(K1), S(K3)) CALL MPDIVD (S(K3), T2, 0, S(K1)) CALL MPADD (S(K1), S(K0), S(K3)) CALL MPEQ (S(K3), S(K0)) C C Check for convergence of the series. C IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. S(K0+1) - NW) GOTO 100 C C Compute Cos (s) = Sqrt [1 - Sin^2 (s)]. C 110 CALL MPEQ (S(K0), S(K1)) CALL MPMUL (S(K0), S(K0), S(K2)) CALL MPSUB (F, S(K2), S(K3)) CALL MPSQRT (S(K3), S(K0)) C C Compute cosine and sine of b * Pi / 16. C KC = ABS (KB) F(3) = 2. IF (KC .EQ. 0) THEN S(K2) = 1. S(K2+1) = 0. S(K2+2) = 1. S(K3) = 0. S(K3+1) = 0. ELSE IF (KC .EQ. 1) THEN CALL MPSQRT (F, S(K4)) CALL MPADD (F, S(K4), S(K5)) CALL MPSQRT (S(K5), S(K4)) ELSEIF (KC .EQ. 2) THEN CALL MPSQRT (F, S(K4)) ELSEIF (KC .EQ. 3) THEN CALL MPSQRT (F, S(K4)) CALL MPSUB (F, S(K4), S(K5)) CALL MPSQRT (S(K5), S(K4)) ELSEIF (KC .EQ. 4) THEN S(K4) = 0. S(K4+1) = 0. ENDIF CALL MPADD (F, S(K4), S(K5)) CALL MPSQRT (S(K5), S(K3)) CALL MPMULD (S(K3), 0.5D0, 0, S(K2)) CALL MPSUB (F, S(K4), S(K5)) CALL MPSQRT (S(K5), S(K4)) CALL MPMULD (S(K4), 0.5D0, 0, S(K3)) ENDIF IF (KB .LT. 0) S(K3) = - S(K3) C C Apply the trigonometric summation identities to compute cosine and sine of C s + b * Pi / 16. C CALL MPMUL (S(K0), S(K2), S(K4)) CALL MPMUL (S(K1), S(K3), S(K5)) CALL MPSUB (S(K4), S(K5), S(K6)) CALL MPMUL (S(K1), S(K2), S(K4)) CALL MPMUL (S(K0), S(K3), S(K5)) CALL MPADD (S(K4), S(K5), S(K1)) CALL MPEQ (S(K6), S(K0)) C C This code in effect applies the trigonometric summation identities for C (s + b * Pi / 16) + a * Pi / 2. C IF (KA .EQ. 0) THEN CALL MPEQ (S(K0), X) CALL MPEQ (S(K1), Y) ELSEIF (KA .EQ. 1) THEN CALL MPEQ (S(K1), X) X(1) = - X(1) CALL MPEQ (S(K0), Y) ELSEIF (KA .EQ. -1) THEN CALL MPEQ (S(K1), X) CALL MPEQ (S(K0), Y) Y(1) = - Y(1) ELSEIF (KA .EQ. 2 .OR. KA .EQ. -2) THEN CALL MPEQ (S(K0), X) X(1) = - X(1) CALL MPEQ (S(K1), Y) Y(1) = - Y(1) ENDIF C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (X) CALL MPROUN (Y) C 120 IF (IDB .GE. 6) THEN WRITE (LDB, 3) L1 3 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPCSSN O', X) CALL MPDEB ('MPCSSN O', Y) ENDIF RETURN END C SUBROUTINE MPCSSX (A, PI, X, Y) C C This computes the cosine and sine of the MP number A and returns the two MP C results in X and Y, respectively. PI is the MP value of Pi computed by a C previous call to MPPI or MPPIX. Before calling MPCSSX, the array in C MPCOM5 must be initialized by calling MPINIX. For modest levels of C precision, use MPCSSN. NW should be a power of two. The last four words C of the result are not reliable. Debug output starts with IDB = 5. C C Max SP space for X and Y: NW + 4 cells. Max SP scratch space: 26*NW + 110 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs a complex arithmetic version of the scheme used in C MPEXPX. C DOUBLE PRECISION CL2, CPI, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, CPI = 3.141592653589793D0, $ NIT = 1) DIMENSION A(NW+2), F1(8), PI(NW+2), X(NW+4), Y(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. Y(1) = 0. Y(2) = 0. RETURN ENDIF IF (IDB .GE. 5) CALL MPDEB ('MPCSSX I', A) C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) NCR = 2 ** MCR C C Check if precision level is too low to justify advanced routine. C IF (NW .LE. NCR) THEN CALL MPCSSN (A, PI, X, Y) L1 = 0 GOTO 120 ENDIF C C Check if input is zero. C IF (NA .EQ. 0) THEN X(1) = 1. X(2) = 0. X(3) = 1. Y(1) = 0. Y(2) = 0. L1 = 0 GOTO 120 ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T1, N1) IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN IF (KER(30) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPCSSX: PI must be precomputed.') IER = 30 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 N42 = 2 * N4 NS = 4 * N42 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N42 K2 = K1 + N42 K3 = K2 + N42 F1(1) = 1. F1(2) = 0. F1(3) = 1. NWS = NW C C Reduce argument to between - Pi and Pi. C CALL MPMULD (PI, 2.D0, 0, S(K0)) CALL MPDIVX (A, S(K0), S(K1)) CALL MPNINT (S(K1), S(K2)) CALL MPMUL (S(K2), S(K0), S(K1)) CALL MPSUB (A, S(K1), S(K0)) C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T2 = NWS MQ = CL2 * LOG (T2) + 1.D0 - RXX CALL MPEQ (F1, S(K2)) C C Compute initial approximation to [Cos (A), Sin (A)]. C NW = NCR CALL MPCSSN (S(K0), PI, S(K3), S(K3+N4)) IQ = 0 C C Perform the Newton-Raphson iteration with a dynamically changing precision C level NW. C DO 110 K = MCR + 1, MQ NW = MIN (2 * NW, NWS) 100 CONTINUE CALL MPANGX (S(K3), S(K3+N4), PI, S(K1)) CALL MPSUB (S(K0), S(K1), S(K2+N4)) CALL MPCMLX (N4, S(K3), S(K2), S(K1)) CALL MPCEQ (N4, S(K1), S(K3)) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C The final (cos, sin) result must be normalized to have magnitude 1. C CALL MPMULX (S(K3), S(K3), S(K0)) CALL MPMULX (S(K3+N4), S(K3+N4), S(K0+N4)) CALL MPADD (S(K0), S(K0+N4), S(K1)) CALL MPSQRX (S(K1), S(K2)) CALL MPDIVX (S(K3), S(K2), S(K0)) CALL MPDIVX (S(K3+N4), S(K2), S(K0+N4)) CALL MPMPCM (N4, S(K0), X, Y) ICS = ISS C 120 IF (IDB .GE. 5) THEN CALL MPDEB ('MPCSSX O', X) CALL MPDEB ('MPCSSX O', Y) ENDIF RETURN END C SUBROUTINE MPCSUB (L, A, B, C) C C This subracts the MPC numbers A and B and returns the MPC difference in C C. L is the offset between real and imaginary parts in A, B and C. L C must be at least NW + 4. Debug output starts with IDB = 9. C C Max SP space for C: 2 * L cells. C DIMENSION A(2*L), B(2*L), C(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF IF (IDB .GE. 9) WRITE (LDB, 1) 1 FORMAT ('MPCSUB') C L1 = L + 1 CALL MPSUB (A, B, C) CALL MPSUB (A(L1), B(L1), C(L1)) C RETURN END C SUBROUTINE MPDEB (CS, A) C C This outputs the character string CS, the exponent of the MP number A, and C the first 50 digits of A, all on one line. CS must either be a literal C string not exceeding 12 characters in length or a variable of type C CHARACTER*n, where n does not exceed 12. C CHARACTER*(*) CS CHARACTER*1 B(160) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) DIMENSION A(NW+2) C IF (IER .NE. 0) RETURN IDS = IDB IDB = 0 NWS = NW NW = MIN (NW, 10) CALL MPOUTC (A, B, N) N = MIN (N, 70) WRITE (LDB, 1) CS, ' ', (B(K), K = 1, 4), (B(K), K = 9, N) 1 FORMAT (A12,67A1:/(79A1)) IDB = IDS NW = NWS RETURN END C SUBROUTINE MPDIV (A, B, C) C C This divides the MP number A by the MP number B to yield the MP quotient C. C For extra high levels of precision, use MPDIVX. Debug output starts with C IDB = 8. C C Max SP space for C: NW + 4 cells. Max DP scratch space: NW + 4 cells. C DOUBLE PRECISION D, RB, SS, T1, T2, T3 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM4/ D(1024) DIMENSION A(NW+2), B(NW+2), C(NW+4) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPDIV I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF C IA = SIGN (1., A(1)) IB = SIGN (1., B(1)) NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) C C Check if dividend is zero. C IF (NA .EQ. 0) THEN C(1) = 0. C(2) = 0. GOTO 190 ENDIF IF (NB .EQ. 1 .AND. B(3) .EQ. 1.) THEN C C Divisor is 1 or -1 -- result is A or -A. C C(1) = SIGN (NA, IA * IB) C(2) = A(2) - B(2) C DO 100 I = 3, NA + 2 C(I) = A(I) 100 CONTINUE C GOTO 190 ENDIF C C Check if divisor is zero. C IF (NB .EQ. 0) THEN IF (KER(31) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPDIV: Divisor is zero.') IER = 31 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Initialize trial divisor and trial dividend. C T1 = BDX * B(3) IF (NB .GE. 2) T1 = T1 + B(4) IF (NB .GE. 3) T1 = T1 + RDX * B(5) IF (NB .GE. 4) T1 = T1 + RX2 * B(6) RB = 1.D0 / T1 MD = MIN (NA + NB, NW) D(1) = 0.D0 C DO 110 I = 2, NA + 1 D(I) = A(I+1) 110 CONTINUE C DO 120 I = NA + 2, MD + 4 D(I) = 0.D0 120 CONTINUE C C Perform ordinary long division algorithm. First compute only the first C NA words of the quotient. C> DO 140 J = 2, NA + 1 T1 = INT (RB * (BX2 * D(J-1) + BDX * D(J) + D(J+1))) J3 = J - 3 I2 = MIN (NB, NW + 2 - J3) + 2 C> CDIR$ IVDEP DO 130 I = 3, I2 I3 = I + J3 T2 = D(I3) - T1 * B(I) T3 = INT (T2 * RDX) D(I3) = T2 - T3 * BDX D(I3-1) = D(I3-1) + T3 130 CONTINUE C C If the trial divisor was correct, D(J-1) will be zero. If D(J-1) is not C zero, add it (multiplied by the radix) into D(J). C D(J) = D(J) + BDX * D(J-1) D(J-1) = T1 140 CONTINUE C C Compute additional words of the quotient, as long as the remainder C is nonzero. C> DO 160 J = NA + 2, NW + 3 T1 = INT (RB * (BX2 * D(J-1) + BDX * D(J) + D(J+1))) J3 = J - 3 I2 = MIN (NB, NW + 2 - J3) + 2 IJ = I2 + J3 SS = 0.D0 C> CDIR$ IVDEP DO 150 I = 3, I2 I3 = I + J3 T2 = D(I3) - T1 * B(I) T3 = INT (T2 * RDX) D(I3) = T2 - T3 * BDX D(I3-1) = D(I3-1) + T3 SS = SS + ABS (D(I3-1)) 150 CONTINUE C SS = SS + ABS (D(IJ)) D(J) = D(J) + BDX * D(J-1) D(J-1) = T1 IF (SS .EQ. 0.D0) GOTO 170 IF (IJ .LE. NW + 2) D(IJ+2) = 0.D0 160 CONTINUE C C Set sign and exponent, and fix up result. C J = NW + 3 C 170 D(J) = 0.D0 IF (D(1) .EQ. 0.D0) THEN IS = 1 ELSE IS = 2 ENDIF NC = MIN (J - 1, NW) D(NC+3) = 0.D0 D(NC+4) = 0.D0 C DO 180 I = J + 1, 3, -1 D(I) = D(I-IS) 180 CONTINUE C D(1) = SIGN (NC, IA * IB) D(2) = A(2) - B(2) + IS - 2 CALL MPNORM (C) C 190 IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 3) (C(I), I = 1, NO) 3 FORMAT ('MPDIV O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPDIVD (A, B, N, C) C C This routine divides the MP number A by the DPE number (B, N) to yield C the MP quotient C. Debug output starts with IDB = 9. C C Max SP space for C: NW + 4 cells. Max DP space: NW + 4 cells. C DOUBLE PRECISION B, BB, BR, D, DD, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) COMMON /MPCOM4/ D(1024) DIMENSION A(NW+2), C(NW+4), F(8) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPDIVD I'/(6F12.0)) WRITE (LDB, 2) B, N 2 FORMAT ('MPDIVD I',1PD25.15,I10) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) IB = SIGN (1.D0, B) C C Check if dividend is zero. C IF (NA .EQ. 0) THEN C(1) = 0. C(2) = 0. GOTO 150 ENDIF C C Check if divisor is zero. C IF (B .EQ. 0.D0) THEN IF (KER(32) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPDIVD: Divisor is zero.') IER = 32 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF N1 = N / NBT N2 = N - NBT * N1 BB = ABS (B) * 2.D0 ** N2 C C Reduce BB to within 1 and BDX. C IF (BB .GE. BDX) THEN C DO 100 K = 1, 100 BB = RDX * BB IF (BB .LT. BDX) THEN N1 = N1 + K GOTO 120 ENDIF 100 CONTINUE C ELSEIF (BB .LT. 1.D0) THEN C DO 110 K = 1, 100 BB = BDX * BB IF (BB .GE. 1.D0) THEN N1 = N1 - K GOTO 120 ENDIF 110 CONTINUE C ENDIF C C If B cannot be represented exactly in a single mantissa word, use MPDIV. C 120 IF (BB .NE. AINT (BB)) THEN BB = SIGN (BB, B) CALL MPDMC (BB, N1 * NBT, F) CALL MPDIV (A, F, C) GOTO 150 ENDIF C BR = 1.D0 / BB DD = A(3) C C Perform short division (not vectorizable at present). Continue as long as C the remainder remains nonzero. C> DO 130 J = 2, NW + 3 T1 = INT (BR * DD) D(J+1) = T1 DD = BDX * (DD - T1 * BB) IF (J .LE. NA) THEN DD = DD + A(J+2) ELSE IF (DD .EQ. 0.D0) GOTO 140 ENDIF 130 CONTINUE C C Set sign and exponent of result. C J = NW + 3 C 140 NC = MIN (J - 1, NW) D(1) = SIGN (NC, IA * IB) D(2) = A(2) - N1 IF (J .LE. NW + 2) D(J+2) = 0.D0 IF (J .LE. NW + 1) D(J+3) = 0.D0 CALL MPNORM (C) C 150 IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 4) (C(I), I = 1, NO) 4 FORMAT ('MPDIVD O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPDIVX (A, B, C) C C This divides the MP number A by the MP number B and returns the MP result C in C. Before calling MPDIVX, the array in MPCOM5 must be initialized by C calling MPINIX. For modest levels of precision, use MPDIV. NW should be C a power of two. The last two words of the result are not reliable. Debug C output starts with IDB = 7. C C Max SP space for C: NW + 4 cells. Max SP scratch space: 2 * NW + 8 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This subroutine employs the following Newton-Raphson iteration, which C converges to 1 / B: C C X_{k+1} = X_k + X_k * (1 - B * X_k) C C Multiplying the final approximation to 1 / B by A gives the quotient. C These iterations are performed with a maximum precision level NW that C is dynamically changed, doubling with each iteration. C C One difficulty with this procedure is that errors often accumulate in the C trailing mantissa words. This error can be controlled by repeating one of C the iterations. The iteration that is repeated is controlled by setting C the parameter NIT below: If NIT = 0, the last iteration is repeated (this C is most effective but most expensive). If NIT = 1, then the next-to-last C iteration is repeated, etc. An extra word of precision cannot be used in C this routine (since MPMULX prefers powers of two), so NIT = 0 or 1 is best C unless the user needs maximum speed. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1) DIMENSION A(NW+2), B(NW+2), C(NW+4), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPDIVX I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF C IA = SIGN (1., A(1)) IB = SIGN (1., B(1)) NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) NCR = 2 ** MCR C C Check if dividend is zero. C IF (NA .EQ. 0) THEN C(1) = 0. C(2) = 0. GOTO 120 ENDIF C C Check if divisor is zero. C IF (NB .EQ. 0) THEN IF (KER(33) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPDIVX: Divisor is zero.') IER = 33 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if precision level of divisor is too low to justify the advanced C routine. C IF (NB .LE. NCR) THEN CALL MPDIV (A, B, C) GOTO 120 ENDIF N4 = NW + 4 NS = 2 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Compute the initial approximation of 1 / B to a precision of NCR words. C NW = NCR F(1) = 1. F(2) = 0. F(3) = 1. CALL MPDIV (F, B, C) IQ = 0 C C Perform the Newton-Raphson iterations described above. C DO 110 K = MCR + 1, MQ AN = NW NW = MIN (2 * NW, NWS) 100 CONTINUE CALL MPMULX (B, C, S(K0)) CALL MPSUB (F, S(K0), S(K1)) S(K1) = SIGN (MIN (ABS (S(K1)), AN), S(K1)) CALL MPMULX (C, S(K1), S(K0)) CALL MPADD (C, S(K0), S(K1)) CALL MPEQ (S(K1), C) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Multiply by A to give final result. C CALL MPMULX (A, C, S(K1)) CALL MPEQ (S(K1), C) ICS = ISS C 120 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 3) (C(I), I = 1, NO) 3 FORMAT ('MPDIVX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPDMC (A, N, B) C C This routine converts the DPE number (A, N) to MP form in B. All bits of C A are recovered in B. However, note for example that if A = 0.1D0 and N C is 0, then B will NOT be the multiprecision equivalent of 1/10. Debug C output starts with IDB = 9. C C Max SP space for B: 8 cells. C DOUBLE PRECISION A, AA DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS DIMENSION B(NW+4) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 9) WRITE (LDB, 1) A, N 1 FORMAT ('MPDMC I',1PD25.15,I10) C C Check for zero. C IF (A .EQ. 0.D0) THEN B(1) = 0. B(2) = 0. GOTO 150 ENDIF N1 = N / NBT N2 = N - NBT * N1 AA = ABS (A) * 2.D0 ** N2 C C Reduce AA to within 1 and BDX. C IF (AA .GE. BDX) THEN C DO 100 K = 1, 100 AA = RDX * AA IF (AA .LT. BDX) THEN N1 = N1 + K GOTO 120 ENDIF 100 CONTINUE C ELSEIF (AA .LT. 1.D0) THEN C DO 110 K = 1, 100 AA = BDX * AA IF (AA .GE. 1.D0) THEN N1 = N1 - K GOTO 120 ENDIF 110 CONTINUE C ENDIF C C Store successive sections of AA into B. C 120 B(2) = N1 B(3) = AINT (AA) AA = BDX * (AA - B(3)) B(4) = AINT (AA) AA = BDX * (AA - B(4)) B(5) = AINT (AA) AA = BDX * (AA - B(5)) B(6) = AINT (AA) B(7) = 0. B(8) = 0. C DO 130 I = 6, 3, -1 IF (B(I) .NE. 0.) GOTO 140 130 CONTINUE C 140 AA = I - 2 B(1) = SIGN (AA, A) C 150 IF (IDB .GE. 9) THEN NO = ABS (B(1)) + 2. WRITE (LDB, 2) (B(I), I = 1, NO) 2 FORMAT ('MPDMC O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPEQ (A, B) C C This routine sets the MP number B equal to the MP number A. Debug output C starts with IDB = 10. C C Max SP space for B: NW + 2 cells. C C The fact that only NW + 2 cells, and not NW + 4 cells, are copied is C important in some routines that increase the precision level by one. C PARAMETER (NDB = 22) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS DIMENSION A(NW+2), B(NW+2) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 10) WRITE (LDB, 1) 1 FORMAT ('MPEQ') C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) B(1) = SIGN (NA, IA) C DO 100 I = 2, NA + 2 B(I) = A(I) 100 CONTINUE C RETURN END C SUBROUTINE MPEXP (A, AL2, B) C C This computes the exponential function of the MP number A and returns the C MP result in B. AL2 is the MP value of Log(2) produced by a prior call C to MPLOG. For extra high levels of precision, use MPEXPX. The last C word of the result is not reliable. Debug output starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 5 * NW + 25 C cells. Max DP scratch space: NW + 5 cells. C C This routine uses a modification of the Taylor's series for Exp (t): C C Exp (t) = (1 + r + r^2 / 2! + r^3 / 3! + r^4 / 4! ...) ^ q * 2 ^ n C C where q = 256, r = t' / q, t' = t - n Log(2) and where n is chosen so C that -0.5 Log(2) < t' <= 0.5 Log(2). Reducing t mod Log(2) and C dividing by 256 insures that -0.001 < r <= 0.001, which accelerates C convergence in the above series. C DOUBLE PRECISION ALT, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (ALT = 0.693147180559945309D0, NQ = 8) DIMENSION A(NW+2), B(NW+5), AL2(NW+2), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) CALL MPDEB ('MPEXP I', A) C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) CALL MPMDC (A, T1, N1) T1 = T1 * 2.D0 ** N1 C C Unless the argument is near Log (2), Log(2) must be precomputed. This C exception is necessary because MPLOG calls MPEXP to initialize Log (2). C IF (ABS (T1 - ALT) .GT. RDX) THEN CALL MPMDC (AL2, T2, N2) IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2) $ THEN IF (KER(34) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPEXP: LOG (2) must be precomputed.') IER = 34 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C C Check for overflows and underflows. C IF (T1 .GE. 1D9) THEN IF (T1 .GT. 0.D0) THEN IF (KER(35) .NE. 0) THEN WRITE (LDB, 2) T1, N1 2 FORMAT ('*** MPEXP: Argument is too large',F12.6,' x 10 ^', $ I8) IER = 35 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ELSE B(1) = 0. B(2) = 0. L1 = 0 GOTO 130 ENDIF ENDIF C N5 = NW + 5 NS = 4 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 NWS = NW NW = NW + 1 F(1) = 1. F(2) = 0. F(3) = 1. C C Compute the reduced argument A' = A - Log(2) * Nint [A / Log(2)]. Save C NZ = Nint [A / Log(2)] for correcting the exponent of the final result. C IF (ABS (T1 - ALT) .GT. RDX) THEN CALL MPDIV (A, AL2, S(K0)) CALL MPNINT (S(K0), S(K1)) CALL MPMDC (S(K1), T1, N1) NZ = T1 * 2.D0 ** N1 + SIGN (RXX, T1) CALL MPMUL (AL2, S(K1), S(K2)) CALL MPSUB (A, S(K2), S(K0)) ELSE CALL MPEQ (A, S(K0)) NZ = 0 ENDIF TL = S(K0+1) - NW C C Check if the reduced argument is zero. C IF (S(K0) .EQ. 0.D0) THEN S(K0) = 1. S(K0+1) = 0. S(K0+2) = 1. L1 = 0 GOTO 120 ENDIF C C Divide the reduced argument by 2 ^ NQ. C CALL MPDIVD (S(K0), 1.D0, NQ, S(K1)) C C Compute Exp using the usual Taylor series. C CALL MPEQ (F, S(K2)) CALL MPEQ (F, S(K3)) L1 = 0 C 100 L1 = L1 + 1 IF (L1 .EQ. 10000) THEN IF (KER(36) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPEXP: Iteration limit exceeded.') IER = 36 IF (KER(IER) .EQ. 2) CALL MPABRT NW = NWS ICS = ISS RETURN ENDIF ENDIF C T2 = L1 CALL MPMUL (S(K2), S(K1), S(K0)) CALL MPDIVD (S(K0), T2, 0, S(K2)) CALL MPADD (S(K3), S(K2), S(K0)) CALL MPEQ (S(K0), S(K3)) C C Check for convergence of the series. C IF (S(K2) .NE. 0. .AND. S(K2+1) .GE. TL) GOTO 100 C C Raise to the (2 ^ NQ)-th power. C DO 110 I = 1, NQ CALL MPMUL (S(K0), S(K0), S(K1)) CALL MPEQ (S(K1), S(K0)) 110 CONTINUE C C Multiply by 2 ^ NZ. C 120 CALL MPMULD (S(K0), 1.D0, NZ, S(K1)) CALL MPEQ (S(K1), B) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) C 130 IF (IDB .GE. 7) THEN WRITE (LDB, 4) L1 4 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPEXP O', B) ENDIF RETURN END C SUBROUTINE MPEXPX (A, PI, AL2, B) C C This computes the exponential function of the MP number A and returns the C MP result in B. PI is the MP value of Pi produced by a prior call to MPPI C or MPPIX. AL2 is the MP value of Log(2) produced by a prior call to C MPLOG or MPLOGX. Before calling MPEXPX, the array in MPCOM5 must be C initialized by calling MPINIX. NW should be a power of two. For modest C levels of precision, use MPEXP. The last four words of the result are C not reliable. Debug output starts with IDB = 5. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 12 * NW + 54 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses the Newton iteration C C b_{k+1} = b_k [a + 1 - log b_k] C C with a dynamically changing level of precision. Logs are performed using C MPLOGX. See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION ALT, CL2, CPI, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (ALT = 0.693147180559945309D0, $ CL2 = 1.4426950408889633D0, CPI = 3.141592653589793238D0, $ NIT = 1) DIMENSION A(NW+2), AL2(NW+2), B(NW+4), F1(8), PI(NW+2) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 5) CALL MPDEB ('MPEXPX I', A) C NCR = 2 ** MCR IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) CALL MPMDC (A, T1, N1) T1 = T1 * 2.D0 ** N1 C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPEXP (A, AL2, B) GOTO 120 ENDIF C C Check if Log(2) has been precomputed. C CALL MPMDC (AL2, T2, N2) IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2) $ THEN IF (KER(37) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPEXPX: LOG (2) must be precomputed.') IER = 37 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T2, N2) IF (N2 .NE. 0 .OR. ABS (T2 - CPI) .GT. RX2) THEN IF (KER(38) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPEXPX: PI must be precomputed.') IER = 38 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check for overflows and underflows. C IF (T1 .GE. 1D9) THEN IF (T1 .GT. 0.D0) THEN IF (KER(39) .NE. 0) THEN WRITE (LDB, 3) T1, N1 3 FORMAT ('*** MPEXPX: Argument is too large',F12.6,' x 10 ^', $ I8) IER = 39 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ELSE B(1) = 0. B(2) = 0. GOTO 120 ENDIF ENDIF C N4 = NW + 4 NS = 3 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 NWS = NW F1(1) = 1. F1(2) = 0. F1(3) = 1. C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T2 = NWS MQ = CL2 * LOG (T2) + 1.D0 - RXX CALL MPADD (A, F1, S(K0)) C C Compute initial approximation to Exp (A). C NW = NCR CALL MPEXP (A, AL2, B) IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW. C DO 110 K = MCR + 1, MQ NW = MIN (2 * NW, NWS) 100 CONTINUE CALL MPLOGX (B, PI, AL2, S(K1)) CALL MPSUB (S(K0), S(K1), S(K2)) CALL MPMULX (B, S(K2), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C ICS = ISS C 120 IF (IDB .GE. 6) CALL MPDEB ('MPEXPX O', B) RETURN END C SUBROUTINE MPFFT1 (IS, L, M, X, Y) C C Performs the L-th iteration of the first variant of the Stockham FFT. C This routine is called by MPCFFT. It is not intended to be called directly C by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION X(*), Y(*) COMMON /MPCOM5/ U(1024) C C Set initial parameters. C N = 2 ** M K = U(1) NU = K / 64 N1 = N / 2 LK = 2 ** (L - 1) LI = 2 ** (M - L) LJ = 2 * LI KU = LI + 1 KN = KU + NU C DO 100 K = 0, LK - 1 I11 = K * LJ + 1 I12 = I11 + LI I21 = K * LI + 1 I22 = I21 + N1 C CDIR$ IVDEP DO 100 I = 0, LI - 1 U1 = U(KU+I) U2 = IS * U(KN+I) X11 = X(I11+I) X12 = X(I11+I+N) X21 = X(I12+I) X22 = X(I12+I+N) T1 = X11 - X21 T2 = X12 - X22 Y(I21+I) = X11 + X21 Y(I21+I+N) = X12 + X22 Y(I22+I) = U1 * T1 - U2 * T2 Y(I22+I+N) = U1 * T2 + U2 * T1 100 CONTINUE C RETURN END C SUBROUTINE MPFFT2 (IS, L, M, X, Y) C C Performs the L-th iteration of the second variant of the Stockham FFT. C This routine is called by MPCFFT. It is not intended to be called directly C by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION X(*), Y(*) COMMON /MPCOM5/ U(1024) C C Set initial parameters. C N = 2 ** M K = U(1) NU = K / 64 N1 = N / 2 LK = 2 ** (L - 1) LI = 2 ** (M - L) LJ = 2 * LK KU = LI + 1 C DO 100 I = 0, LI - 1 I11 = I * LK + 1 I12 = I11 + N1 I21 = I * LJ + 1 I22 = I21 + LK U1 = U(KU+I) U2 = IS * U(KU+I+NU) C CDIR$ IVDEP DO 100 K = 0, LK - 1 X11 = X(I11+K) X12 = X(I11+K+N) X21 = X(I12+K) X22 = X(I12+K+N) T1 = X11 - X21 T2 = X12 - X22 Y(I21+K) = X11 + X21 Y(I21+K+N) = X12 + X22 Y(I22+K) = U1 * T1 - U2 * T2 Y(I22+K+N) = U1 * T2 + U2 * T1 100 CONTINUE C RETURN END C SUBROUTINE MPINFR (A, B, C) C C Sets B to the integer part of the MP number A and sets C equal to the C fractional part of A. Note that if A = -3.3, then B = -3 and C = -0.3. C Debug output starts with IDB = 9. C C Max SP space for B and C: NW + 4 cells. C PARAMETER (NDB = 22) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) DIMENSION A(NW+2), B(NW+2), C(NW+2) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPINFR I'/(6F12.0)) ENDIF C C Check if A is zero. C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) MA = A(2) IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. C(1) = 0. C(2) = 0. GOTO 120 ENDIF C IF (MA .GE. NW - 1) THEN IF (KER(40) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPINFR: Argument is too large.') IER = 40 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Place integer part in B. C NB = MIN (MAX (MA + 1, 0), NA) IF (NB .EQ. 0) THEN B(1) = 0. B(2) = 0. ELSE B(1) = SIGN (NB, IA) B(2) = MA B(NB+3) = 0. B(NB+4) = 0. C DO 100 I = 3, NB + 2 B(I) = A(I) 100 CONTINUE C ENDIF C C Place fractional part in C. C NC = NA - NB IF (NC .LE. 0) THEN C(1) = 0. C(2) = 0. ELSE C(1) = SIGN (NC, IA) C(2) = MA - NB C(NC+3) = 0. C(NC+4) = 0. C DO 110 I = 3, NC + 2 C(I) = A(I+NB) 110 CONTINUE C ENDIF C C Fix up results. B may have trailing zeros and C may have leading zeros. C CALL MPROUN (B) CALL MPROUN (C) C 120 IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPINFR O'/(6F12.0)) NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 3) (C(I), I = 1, NO) ENDIF RETURN END C SUBROUTINE MPINIX (M) C C This initializes the double precision array U in common MPCOM5 with roots C of unity required by the FFT routines, which are called by MPMULX. Before C calling any of the advanced MP routines (i.e. those whose names end in X), C this routine must be called with M set to MX, where MX is defined as the C integer such that 2 ^ MX = NX, and where NX is the largest precision level C NW that will be used in the subsequent application. Before calling MPINIX, C the user must allocate at least 2^(M + 3) double precision cells in common C MPCOM5, which must be placed in the user's main program. Also, at least C 12 * NW + 6 double precision cells must be allocated in common MPCOM4. C Only one call to MPINIX is required, no matter how many advanced routines C are called. It is not necessary for the user to call MPINIX, to allocate C space in MPCOM5 or to allocate more than NW + 6 cells in MPCOM4 if the C advanced routines are not called. C DOUBLE PRECISION PI, T1, T2, U PARAMETER (PI = 3.141592653589793238D0) COMMON /MPCOM5/ U(1024) C C Initialize the U array with sines and cosines in a manner that permits C stride one access at each FFT iteration. C MM = M + 2 N = 2 ** MM NU = N U(1) = 64 * N + MM KU = 2 KN = KU + NU LN = 1 C DO 110 J = 1, MM T1 = PI / LN C CDIR$ IVDEP DO 100 I = 0, LN - 1 T2 = I * T1 U(I+KU) = COS (T2) U(I+KN) = SIN (T2) 100 CONTINUE C KU = KU + LN KN = KU + NU LN = 2 * LN 110 CONTINUE C RETURN END C SUBROUTINE MPINP (IU, A, CS) C C This routine reads the MP number A from logical unit IU. CS is a scratch C array of type CHARACTER*1. CS must be dimensioned at least 7.225*NW + 100. C The digits of A may span more than one line. A comma at the end of the C last line denotes the end of the MP number. The input lines may not C exceed 120 characters in length. Embedded blanks are allowed anywhere. C However, if the input number contains more than 80 embedded blanks, then C the dimension of CS must be increased by a corresponding amount. The C exponent is optional in the input number, but if present it must appear C first. Two examples: C C 1073741824., C 10 ^ -4 x 3.14159 26535 89793 23846 26433 83279 C 50288 41971 69399 37510, C C Max SP space for A: NW + 4 cells. Max SP scratch space: 3 * NW + 16 cells. C CHARACTER*120 LIN CHARACTER*1 CS(6*NW+100) DIMENSION A(NW+2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF L = 0 ND = 7.225D0 * NW + 100.D0 C 100 READ (IU, '(A)', END = 150) LIN C DO 110 I = 120, 1, -1 IF (LIN(I:I) .NE. ' ') GOTO 120 110 CONTINUE C GOTO 100 C 120 K = I IF (L .GT. ND) GOTO 140 C DO 130 I = 1, K L = L + 1 IF (L .GT. ND) GOTO 140 CS(L)= LIN(I:I) 130 CONTINUE C 140 IF (LIN(K:K) .NE. ',') GOTO 100 L = L - 1 C 150 CALL MPINPC (CS, L, A) C RETURN END C SUBROUTINE MPINPC (A, N, B) C C Converts the CHARACTER*1 array A of length N into the MP number B. The C string A must be in the format '10^s a x tb.c' where a, b and c are digit C strings; s and t are '-', '+' or blank; x is either 'x' or '*'. Blanks may C be embedded anywhere. The digit string a is limited to nine digits and C 80 total characters, including blanks. The exponent portion (i.e. the C portion up to and including x) and the period may optionally be omitted. C Debug output starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 3 * NW + 16 cells. C C The following example shows how this routine may be used to input a MP C number: C C CHARACTER*1 CX(800) C READ (1, '(80A1)') (CX(I), I = 1, ND) C CALL MPINPC (CX, ND, B) C DOUBLE PRECISION BI CHARACTER*1 A, AI CHARACTER*10 DIG CHARACTER*80 CA PARAMETER (NDB = 22, DIG = '0123456789') DIMENSION A(N), B(NW+4), F(8) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (N, INT (7.225 * NDB) + 20) WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPINPC I'/(78A1)) ENDIF C N5 = NW + 5 NS = 2 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 NWS = NW NW = NW + 1 I1 = 1 NN = 0 C C Find the carat, period, plus or minus sign, whichever comes first. C DO 100 I = 1, N AI = A(I) IF (AI .EQ. '^') GOTO 110 IF (AI .EQ. '.' .OR. AI .EQ. '+' .OR. AI .EQ. '-') GOTO 160 100 CONTINUE C GOTO 160 C C Make sure number preceding the carat is 10. C 110 I2 = I - 1 IF (I2 .GT. 80) GOTO 210 CA = ' ' C DO 120 I = 1, I2 AI = A(I) IF (AI .EQ. ' ') THEN GOTO 120 ELSEIF (INDEX (DIG, AI) .EQ. 0) THEN GOTO 210 ENDIF CA(I:I) = AI 120 CONTINUE C READ (CA, '(BN,I80)') NN IF (NN .NE. 10) GOTO 210 I1 = I2 + 2 C C Find the x or *. C DO 130 I = I1, N AI = A(I) IF (AI .EQ. 'x' .OR. AI .EQ. '*') GOTO 140 130 CONTINUE C GOTO 210 C C Convert the exponent. C 140 I2 = I - 1 L1 = I2 - I1 + 1 IF (L1 .GT. 80) GOTO 210 CA = ' ' ID = 0 IS = 1 C DO 150 I = 1, L1 AI = A(I+I1-1) IF (AI .EQ. ' ' .OR. AI .EQ. '+') THEN GOTO 150 ELSEIF (AI .EQ. '-' .AND. ID .EQ. 0) THEN ID = 1 IS = -1 CA(I:I) = ' ' ELSE IF (INDEX (DIG, AI) .EQ. 0) GOTO 210 ID = 1 CA(I:I) = AI ENDIF 150 CONTINUE C READ (CA, '(BN,I80)') NN NN = IS * NN I1 = I2 + 2 C C Find the next nonblank character. C 160 DO 170 I = I1, N IF (A(I) .NE. ' ') GOTO 180 170 CONTINUE C GOTO 210 C C Check if the nonblank character is a plus or minus sign. C 180 I1 = I IF (A(I1) .EQ. '+') THEN I1 = I1 + 1 IS = 1 ELSEIF (A(I1) .EQ. '-') THEN I1 = I1 + 1 IS = -1 ELSE IS = 1 ENDIF NB = 0 IB = 0 ID = 0 IP = 0 B(1) = 0 B(2) = 0 F(1) = 1. F(2) = 0. IT = 0 C 190 IP = 0 CA(1:6) = '000000' C C Scan for digits, looking for the period also. On the first pass we just C count, so that on the second pass it will come out right. C DO 200 I = I1, N AI = A(I) IF (AI .EQ. ' ') THEN ELSEIF (AI .EQ. '.') THEN IF (IP .NE. 0) GOTO 210 IP = ID ELSEIF (INDEX (DIG, AI) .EQ. 0) THEN GOTO 210 ELSE IB = IB + 1 ID = ID + 1 CA(IB:IB) = AI ENDIF IF (IB .EQ. 6 .OR. I .EQ. N .AND. IB .NE. 0) THEN IF (IT .NE. 0) THEN NB = NB + 1 READ (CA(1:6), '(F6.0)') BI CALL MPMULD (B, 1.D6, 0, S(K0)) IF (BI .NE. 0) THEN F(1) = 1. F(3) = BI ELSE F(1) = 0. ENDIF CALL MPADD (S(K0), F, B) CA(1:6) = '000000' ENDIF IF (I .NE. N) IB = 0 ENDIF 200 CONTINUE C IF (IT .EQ. 0) THEN IB = 6 - IB IF (IB .EQ. 6) IB = 0 IT = 1 GOTO 190 ENDIF IF (IS .EQ. -1) B(1) = - B(1) IF (IP .EQ. 0) IP = ID NN = NN + IP - ID F(1) = 1. F(3) = 10. CALL MPNPWR (F, NN, S(K0)) CALL MPMUL (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) NW = NWS CALL MPROUN (B) ICS = ISS C IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 2) (B(I), I = 1, NO) 2 FORMAT ('MPINPC O'/(6F12.0)) ENDIF GOTO 220 C 210 IF (KER(41) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPINPC: Syntax error in literal string.') IER = 41 IF (KER(IER) .EQ. 2) CALL MPABRT NW = NWS ICS = ISS ENDIF C 220 RETURN END C SUBROUTINE MPINQP (IA, IB) C C This routine returns the value of the parameter whose name is IA in common C MPCOM1. By using this routine instead of merely including the MPCOM1 C block in the code, a user may eliminate the possibility of confusion with C a variable name in his or her program. IA is of type CHARACTER and IB C is the value. C CHARACTER*(*) IA COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IA .EQ. 'NW' .OR. IA .EQ. 'nw') THEN IB = NW ELSEIF (IA .EQ. 'IDB' .OR. IA .EQ. 'idb') THEN IB = IDB ELSEIF (IA .EQ. 'LDB' .OR. IA .EQ. 'ldb') THEN IB = LDB ELSEIF (IA .EQ. 'IER' .OR. IA .EQ. 'ier') THEN IB = IER ELSEIF (IA .EQ. 'MCR' .OR. IA .EQ. 'mcr') THEN IB = MCR ELSEIF (IA .EQ. 'IRD' .OR. IA .EQ. 'ird') THEN IB = IRD ELSEIF (IA .EQ. 'ICS' .OR. IA .EQ. 'ics') THEN IB = ICS ELSEIF (IA .EQ. 'IHS' .OR. IA .EQ. 'ihs') THEN IB = IHS ELSEIF (IA .EQ. 'IMS' .OR. IA .EQ. 'ims') THEN IB = IMS ELSE IB = 0 ENDIF C RETURN END C SUBROUTINE MPINRL (N, LX, X, MN, MT, LR, R, IQ) C C This routine searches for integer relations among the entries of the C N-long MP vector X. An integer relation is an n-long vector r such that C r_1 x_1 + r_2 x_2 + ... + r_n x_n = 0. The entries of x are assumed to C start at X(1), X(LX+1), X(2*LX+1), etc. MN is the Log_10 of the maximum C Euclidean norm of an acceptable relation. IQ is set to 1 if the routine C succeeds in recovering a relation that (1) produces zero to within the C relative tolerance 10^MT and (2) has Euclidean norm less than 10^MN. If C no relation is found that meets these standards, IQ is set to 0. When a C valid relation vector is recovered, it is placed in R, beginning at R(1), C R(LR+1), R(2*LR+1), etc., where LR, like LX, is an input parameter. LR C should be at least MN/6 + 3. For extra-high levels of precision, call C MPINRX. Debug output starts with IDB = 4. When IDB = 5, norm bounds are C output within which no relation can exist. C C Max SP space for R: LR * N cells. Max SP scratch space: C (4 * N^2 + 5 * N + 13) * (NW + 4) cells. Max DP scratch space: NW + 4 C cells. C C A typical application of this routine is to determine if a given computed C real number r is the root of any algebraic equation of degree n - 1 with C integer coefficients. One merely sets x_k = r^(k-1) for k = 1 to n and C calls MPINRL. If an integer relation is found, this relation is the vector C of coefficients of a polynomial satisfied by r. If MPINRL outputs a norm C bound of B, then r is not the root of any polynomial of degree n or less C with integer coefficients, where the Euclidean norm of the vector of C coefficients is less than B. C C It sometimes happens that the "precision exhausted" message is output C before finding a relation that is known to exist. If this happens, C increase NW, the working precision level, as well as scratch space C allocations if necessary, and try again. Typically MT is set to roughly C 10 - 6 * NX, where NX is the precision level used to compute X. Repeating C a run with somewhat higher precision is highly recommended to certify that C bounds results are valid. C C This routine allocates the scratch space array S for arrays. Otherwise the C indexing in MPINRQ is too complicated. C CHARACTER*8 CX PARAMETER (IB = 6) DIMENSION R(LR,N), X(LX,N) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN IQ = 0 RETURN ENDIF IF (IDB .GE. 5) THEN WRITE (LDB, 1) N, LX, MN, LR 1 FORMAT ('MPINRL I',4I6) C DO 100 K = 1, N WRITE (CX, '(I4)') K CALL MPDEB (CX, X(1,K)) 100 CONTINUE C ENDIF C C Check if enough space is allowed for R. C IF (LR .LT. MN / IB + 3) THEN IF (KER(42) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPINRL: Argument LR must be larger to match MN.') IER = 42 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = (4 * N ** 2 + 5 * N + 7) * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS KBN = N * (N + 1) KBS = N + 1 + KBN KC = N * (N + 1) + KBS KU = N * N + KC CALL MPINRQ (N, LX, X, MN, MT, LR, R, IQ, S(K0), S(KBN*N4+K0), $ S(KBS*N4+K0), S(KC*N4+K0), S(KU*N4+K0)) ICS = ISS C IF (IDB .GE. 5) THEN WRITE (LDB, 3) IQ 3 FORMAT ('MPINRL O',I2) IF (IQ .EQ. 1) THEN C DO 110 K = 1, N WRITE (CX, '(I4)') K CALL MPDEB (CX, R(1,K)) 110 CONTINUE C ENDIF ENDIF RETURN END C SUBROUTINE MPINRQ (N, LX, X, MN, MT, LR, R, IQ, B, BN, BS, C, U) C C This routine implements the "Small Integer Relation Algorithm" described C in Hastad, Just, Lagarias, and Schnorr, "Polynomial Time Algorithms for C Finding Integer Relations Among Real Numbers", to appear in SIAM J. on C Computing. This routine is called by MPINRL. It is not intended to be C called directly by the user. C C IMX = Number of iterations after which run is terminated. C ITP = Print interval. Also the interval at which norm bounds are computed. C LB = Reduction in log_10 (BN(N)) from previous iteration. Used to detect C that a tentative relation has been found. C DOUBLE PRECISION AB, BNN, BNS, BNZ, BX, BY, T1, T2, T3, T4, TB DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (IMX = 10000, ITP = 10, ITZ = 100, LB = 20) DIMENSION B(NW+4,N,0:N), BN(NW+4,0:N), BS(NW+4,N,0:N), $ C(NW+4,N,N), R(LR,N), U(NW+4,0:N,0:N), X(LX,N) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C C Step 1: Initialization. C N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 NWS = NW TL = 2 - NW BNS = 0.D0 BNZ = 0.D0 IBS = 0 IBZ = 0 II = 0 IQ = 0 C DO 100 I = 1, N CALL MPEQ (X(1,I), B(1,I,0)) 100 CONTINUE C DO 120 J = 1, N C DO 110 I = 1, N B(1,I,J) = 0. B(2,I,J) = 0. C(1,I,J) = 0. C(2,I,J) = 0. 110 CONTINUE C B(1,J,J) = 1. B(2,J,J) = 0. B(3,J,J) = 1. C(1,J,J) = 1. C(2,J,J) = 0. C(3,J,J) = 1. 120 CONTINUE C DO 180 I = 0, N C DO 130 K = 1, N CALL MPEQ (B(1,K,I), BS(1,K,I)) 130 CONTINUE C DO 160 J = 0, I - 1 S(K0) = 0. S(K0+1) = 0. C DO 140 K = 1, N CALL MPMUL (B(1,K,I), BS(1,K,J), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 140 CONTINUE C IF (BN(1,J) .EQ. 0. .OR. BN(2,J) .LT. TL) THEN U(1,I,J) = 0. U(2,I,J) = 0. ELSE CALL MPDIV (S(K0), BN(1,J), U(1,I,J)) ENDIF U(1,J,I) = 0. U(2,J,I) = 0. C DO 150 K = 1, N CALL MPMUL (U(1,I,J), BS(1,K,J), S(K0)) CALL MPSUB (BS(1,K,I), S(K0), S(K1)) CALL MPEQ (S(K1), BS(1,K,I)) 150 CONTINUE 160 CONTINUE C S(K0) = 0. S(K0+1) = 0. C DO 170 K = 1, N CALL MPMUL (BS(1,K,I), BS(1,K,I), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 170 CONTINUE C CALL MPEQ (S(K0), BN(1,I)) U(1,I,I) = 1. U(2,I,I) = 0. U(3,I,I) = 1. 180 CONTINUE C C Step 2: Termination test. C 190 II = II + 1 IF (IER .NE. 0) RETURN IF (II .GT. IMX) THEN IF (KER(43) .NE. 0) THEN WRITE (LDB, 1) II 1 FORMAT ('*** MPINRQ: Iteration limit exceeded',I6) IER = 43 IF (KER(IER) .EQ. 2) CALL MPABRT ICS = ISS RETURN ENDIF ENDIF BX = 0.D0 BY = 0.D0 IX = -10000 IY = -10000 C DO 200 I = 1, N - 1 CALL MPMDC (BN(1,I), AB, IB) IF ((AB .GT. BX .AND. IB .EQ. IX) .OR. (AB .NE. 0.D0 $ .AND. IB .GT. IX)) THEN BX = AB IX = IB ENDIF CALL DPMUL (2.D0 ** I, 0, AB, IB, T1, N1) IF ((T1 .GT. BY .AND. N1 .EQ. IY) .OR. (T1 .NE. 0.D0 $ .AND. N1 .GT. IY)) THEN BY = T1 IY = N1 I1 = I ENDIF 200 CONTINUE C CALL DPSQRT (BX, IX, T1, N1) CALL DPDIV (1.D0, 0, T1, N1, T2, N2) CALL DPDEC (T2, N2, TB, NB) CALL MPMDC (BN(1,N), T2, N2) CALL DPDEC (T2, N2, BNN, IBN) IF ((IDB .GE. 5 .AND. MOD (II, ITP) .EQ. 0) .OR. IDB .GE. 6) THEN WRITE (LDB, 2) II, TB, NB, BNN, IBN 2 FORMAT ('Iteration', I6/ 'Norm bound =', F10.6, ' x 10^', I6, $ 4X, 'BN(N) =', F10.6, ' x 10^', I6) IF (IDB .GE. 6) THEN WRITE (LDB, 3) 3 FORMAT ('BSTAR square norms:') CALL MPMOUT (1, N, BN(1,1)) ENDIF IF (IDB .GE. 7) THEN WRITE (LDB, 4) 4 FORMAT ('B Matrix') CALL MPMOUT (N, N + 1, B) WRITE (LDB, 5) 5 FORMAT ('U Matrix') CALL MPMOUT (N + 1, N + 1, U) ENDIF ENDIF IF (NB .GT. MN) GOTO 280 C C Test if current BN(N) is 10^LB times the previous BN(N). C IF (BNN .NE. 0.D0 .AND. IBN .GT. IBS + LB) THEN IF (IDB .GE. 5) WRITE (LDB, 6) II, BNN, IBN 6 FORMAT (/'Tentative relation, iteration', I6, 4X, 'BN(N) =', $ F10.6, ' x 10^', I6) C C Compute residual and norm of tentative relation. C DO 220 K = N, 1, -1 T2 = 0.D0 N2 = 0 S(K0) = 0. S(K0+1) = 0. C DO 210 J = 1, N NW = LR - 2 CALL MPEQ (C(1,J,K), R(1,J)) NW = NWS CALL MPMDC (R(1,J), T1, N1) CALL DPMUL (T1, N1, T1, N1, T3, N3) CALL DPADD (T2, N2, T3, N3, T4, N4) T2 = T4 N2 = N4 CALL MPMUL (R(1,J), X(1,J), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 210 CONTINUE C C If the residual is zero or within tolerance 10^MT of zero, it is a real C relation. Otherwise it was a false alarm. C CALL MPMDC (S(K0), T3, N3) CALL DPDEC (T3, N3, T1, N1) IF (T1 .EQ. 0.D0 .OR. N1 .LE. MT) THEN IF (IDB .GE. 4) THEN CALL DPSQRT (T2, N2, T3, N3) CALL DPDEC (T3, N3, T1, N1) CALL MPMDC (S(K0), T4, N4) CALL DPDEC (T4, N4, T2, N2) WRITE (LDB, 7) K, T1, N1, T2, N2 7 FORMAT ('Relation in column',I4,3X,'Norm =',F10.6, $ ' x 10^',I6/'Residual =',F10.6,' x 10^',I6) ENDIF IQ = 1 GOTO 280 ENDIF 220 CONTINUE C ENDIF C C Test if BN(N) is the same as ITZ iterations ago. C IF (MOD (II, ITZ) .EQ. 0) THEN IF (BNN .EQ. BNZ .AND. IBN .EQ. IBZ) THEN IF (KER(44) .NE. 0) THEN WRITE (LDB, 8) INT (LOG10 (BDX) * (NW + 3)) 8 FORMAT ('*** MPINRQ: Numeric overflow has occurred. Call ', $ 'MPINRL with at least',I8/'digits precision.') IER = 44 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ICS = ISS RETURN ENDIF BNZ = BNN IBZ = IBN ENDIF BNS = BNN IBS = IBN C C Step 3: Update B and C for transformation and then exchange B and C. C I2 = I1 + 1 C C Check if U(i2,i1) can be converted exactly to an integer. The error C number and message are the same as the previous one. C IF (ABS (U(2,I2,I1)) .GE. NW - 1) THEN IF (KER(45) .NE. 0) THEN WRITE (LDB, 8) INT (LOG10 (BDX) * ABS (U(2,I2,I1))) IER = 45 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ICS = ISS RETURN ENDIF CALL MPNINT (U(1,I2,I1), S(K0)) C DO 230 K = 1, N CALL MPMUL (S(K0), B(1,K,I1), S(K1)) CALL MPSUB (B(1,K,I2), S(K1), S(K2)) CALL MPEQ (S(K2), B(1,K,I2)) CALL MPMUL (S(K0), C(1,K,I2), S(K1)) CALL MPADD (C(1,K,I1), S(K1), S(K2)) CALL MPEQ (S(K2), C(1,K,I1)) 230 CONTINUE C DO 240 K = 1, N CALL MPEQ (B(1,K,I1), S(K1)) CALL MPEQ (B(1,K,I2), B(1,K,I1)) CALL MPEQ (S(K1), B(1,K,I2)) CALL MPEQ (C(1,K,I1), S(K1)) CALL MPEQ (C(1,K,I2), C(1,K,I1)) CALL MPEQ (S(K1), C(1,K,I2)) 240 CONTINUE C C Update U for transformation. C DO 250 J = 0, I1 CALL MPMUL (S(K0), U(1,I1,J), S(K1)) CALL MPSUB (U(1,I2,J), S(K1), S(K2)) CALL MPEQ (S(K2), U(1,I2,J)) 250 CONTINUE C C Update BN and U for exchange. C CALL MPEQ (U(1,I2,I1), S(K0)) CALL MPMUL (S(K0), S(K0), S(K1)) CALL MPMUL (S(K1), BN(1,I1), S(K2)) CALL MPADD (BN(1,I2), S(K2), S(K1)) IF (S(K1) .NE. 0. .AND. S(K1+1) .GT. TL) THEN CALL MPDIV (BN(1,I1), S(K1), S(K2)) CALL MPMUL (BN(1,I2), S(K2), S(K3)) CALL MPEQ (S(K3), BN(1,I2)) CALL MPMUL (S(K0), S(K2), S(K3)) CALL MPEQ (S(K3), U(1,I2,I1)) ELSE CALL MPEQ (BN(1,I1), BN(1,I2)) U(1,I2,I1) = 0. U(2,I2,I1) = 0. ENDIF CALL MPEQ (S(K1), BN(1,I1)) C DO 260 J = 1, I1 - 1 CALL MPEQ (U(1,I1,J), S(K1)) CALL MPEQ (U(1,I2,J), U(1,I1,J)) CALL MPEQ (S(K1), U(1,I2,J)) 260 CONTINUE C S(K1) = 1. S(K1+1) = 0. S(K1+2) = 1. C DO 270 J = I1 + 2, N CALL MPMUL (U(1,J,I1), U(1,I2,I1), S(K2)) CALL MPMUL (S(K0), U(1,I2,I1), S(K3)) CALL MPSUB (S(K1), S(K3), S(K4)) CALL MPMUL (U(1,J,I2), S(K4), S(K3)) CALL MPADD (S(K2), S(K3), S(K4)) CALL MPMUL (S(K0), U(1,J,I2), S(K2)) CALL MPSUB (U(1,J,I1), S(K2), U(1,J,I2)) CALL MPEQ (S(K4), U(1,J,I1)) 270 CONTINUE C GOTO 190 C 280 IF (IDB .GE. 4) WRITE (6, 9) II, TB, NB 9 FORMAT ('No. iterations =',I6/'Max. bound =',1PD15.6, $ ' x 10^',I5) ICS = ISS RETURN END C SUBROUTINE MPINRX (N, LX, X, MN, MT, LR, R, IQ) C C This routine searches for integer relations among the entries of the C N-long MP vector X. An integer relation is an n-long vector r such that C r_1 x_1 + r_2 x_2 + ... + r_n x_n = 0. The entries of x are assumed to C start at X(1), X(LX+1), X(2*LX+1), etc. MN is the Log_10 of the maximum C Euclidean norm of an acceptable relation. IQ is set to 1 if the routine C succeeds in recovering a relation that (1) produces zero to within the C relative tolerance 10^MT and (2) has Euclidean norm less than 10^MN. If C no relation is found that meets these standards, IQ is set to 0. When a C valid relation vector is recovered, it is placed in R, beginning at R(1), C R(LR+1), R(2*LR+1), etc., where LR, like LX, is an input parameter. LR C should be at least MN/6 + 3. Before calling MPINRX, the array in MPCOM5 C must be initialized by calling MPINIX. For modest levels of precision, C call MPINRL. Debug output starts with IDB = 4. When IDB = 5, norm bounds C are output within which no relation can exist. C C Max SP space for R: LR * N cells. Max SP scratch space: C (4 * N^2 + 5 * N + 14) * (NW + 4) cells. Max DP scratch space: 12 * NW + 6 C cells. C C See the comments in MPINRL about applying this routine. C C This allocates the scratch space array S for arrays. Otherwise the C indexing in MPINRZ is too complicated. C CHARACTER*8 CX PARAMETER (IB = 6) DIMENSION R(LR,N), X(LX,N) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN IQ = 0 RETURN ENDIF IF (IDB .GE. 5) THEN WRITE (LDB, 1) N, LX, MN, LR 1 FORMAT ('MPINRX I',4I6) C DO 100 K = 1, N WRITE (CX, '(I4)') K CALL MPDEB (CX, X(1,K)) 100 CONTINUE C ENDIF C C Check if enough space is allowed for R. C IF (LR .LE. MN / IB) THEN IF (KER(46) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPINRX: Argument LR must be larger to match MN.') IER = 46 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if the precision level is too low to justify the advanced routine. C NCR = 2 ** MCR IF (NW .LE. NCR) THEN CALL MPINRL (N, LX, X, MN, MT, LR, R, IQ) GOTO 110 ENDIF C C Compute pointers for arrays. C N4 = NW + 4 NS = (4 * N ** 2 + 5 * N + 7) * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS KBN = N * (N + 1) KBS = N + 1 + KBN KC = N * (N + 1) + KBS KU = N * N + KC CALL MPINRZ (N, LX, X, MN, MT, LR, R, IQ, S(K0), S(KBN*N4+K0), $ S(KBS*N4+K0), S(KC*N4+K0), S(KU*N4+K0)) ICS = ISS C 110 IF (IDB .GE. 5) THEN WRITE (LDB, 3) IQ 3 FORMAT ('MPINRX O',I2) IF (IQ .EQ. 1) THEN C DO 120 K = 1, N WRITE (CX, '(I4)') K CALL MPDEB (CX, R(1,K)) 120 CONTINUE C ENDIF ENDIF RETURN END C SUBROUTINE MPINRZ (N, LX, X, MN, MT, LR, R, IQ, B, BN, BS, C, U) C C This is the extra-high precision version of MPINRQ. See the comments C there for details. C DOUBLE PRECISION AB, BNN, BNS, BNZ, BX, BY, T1, T2, T3, T4, TB DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (IMX = 10000, ITP = 25, ITZ = 250, LB = 20) DIMENSION B(NW+4,N,0:N), BN(NW+4,0:N), BS(NW+4,N,0:N), $ C(NW+4,N,N), R(LR,N), U(NW+4,0:N,0:N), X(LX,N) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C C Step 1: Initialization. C N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 NWS = NW IF (NW .LE. 32) THEN TL = 2 - NW ELSEIF (NW .LE. 256) THEN TL = 3 - NW ELSE TL = 4 - NW ENDIF BNS = 0.D0 BNZ = 0.D0 IBS = 0 IBZ = 0 II = 0 IQ = 0 C DO 100 I = 1, N CALL MPEQ (X(1,I), B(1,I,0)) 100 CONTINUE C DO 120 J = 1, N C DO 110 I = 1, N B(1,I,J) = 0. B(2,I,J) = 0. C(1,I,J) = 0. C(2,I,J) = 0. 110 CONTINUE C B(1,J,J) = 1. B(2,J,J) = 0. B(3,J,J) = 1. C(1,J,J) = 1. C(2,J,J) = 0. C(3,J,J) = 1. 120 CONTINUE C DO 180 I = 0, N C DO 130 K = 1, N CALL MPEQ (B(1,K,I), BS(1,K,I)) 130 CONTINUE C DO 160 J = 0, I - 1 S(K0) = 0. S(K0+1) = 0. C DO 140 K = 1, N CALL MPMULX (B(1,K,I), BS(1,K,J), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 140 CONTINUE C IF (BN(1,J) .EQ. 0. .OR. BN(2,J) .LT. TL) THEN U(1,I,J) = 0. U(2,I,J) = 0. ELSE CALL MPDIVX (S(K0), BN(1,J), U(1,I,J)) ENDIF U(1,J,I) = 0. U(2,J,I) = 0. C DO 150 K = 1, N CALL MPMULX (U(1,I,J), BS(1,K,J), S(K0)) CALL MPSUB (BS(1,K,I), S(K0), S(K1)) CALL MPEQ (S(K1), BS(1,K,I)) 150 CONTINUE 160 CONTINUE C S(K0) = 0. S(K0+1) = 0. C DO 170 K = 1, N CALL MPMULX (BS(1,K,I), BS(1,K,I), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 170 CONTINUE C CALL MPEQ (S(K0), BN(1,I)) U(1,I,I) = 1. U(2,I,I) = 0. U(3,I,I) = 1. 180 CONTINUE C C Step 2: Termination test. C 190 II = II + 1 IF (IER .NE. 0) RETURN IF (II .GT. IMX) THEN IF (KER(47) .NE. 0) THEN WRITE (LDB, 1) II 1 FORMAT ('*** MPINRZ: Iteration limit exceeded',I6) IER = 47 IF (KER(IER) .EQ. 2) CALL MPABRT ICS = ISS RETURN ENDIF ENDIF BX = 0.D0 BY = 0.D0 IX = -10000 IY = -10000 C DO 200 I = 1, N - 1 CALL MPMDC (BN(1,I), AB, IB) IF ((AB .GT. BX .AND. IB .EQ. IX) .OR. (AB .NE. 0.D0 $ .AND. IB .GT. IX)) THEN BX = AB IX = IB ENDIF CALL DPMUL (2.D0 ** I, 0, AB, IB, T1, N1) IF ((T1 .GT. BY .AND. N1 .EQ. IY) .OR. (T1 .NE. 0.D0 $ .AND. N1 .GT. IY)) THEN BY = T1 IY = N1 I1 = I ENDIF 200 CONTINUE C CALL DPSQRT (BX, IX, T1, N1) CALL DPDIV (1.D0, 0, T1, N1, T2, N2) CALL DPDEC (T2, N2, TB, NB) CALL MPMDC (BN(1,N), T2, N2) CALL DPDEC (T2, N2, BNN, IBN) IF ((IDB .GE. 5 .AND. MOD (II, ITP) .EQ. 0) .OR. IDB .GE. 6) THEN WRITE (LDB, 2) II, TB, NB, BNN, IBN 2 FORMAT ('Iteration', I6/ 'Norm bound =', F10.6, ' x 10^', I6, $ 4X, 'BN(N) =', F10.6, ' x 10^', I6) IF (IDB .GE. 6) THEN WRITE (LDB, 3) 3 FORMAT ('BSTAR square norms:') CALL MPMOUT (1, N, BN(1,1)) ENDIF IF (IDB .GE. 7) THEN WRITE (LDB, 4) 4 FORMAT ('B Matrix') CALL MPMOUT (N, N + 1, B) WRITE (LDB, 5) 5 FORMAT ('U Matrix') CALL MPMOUT (N + 1, N + 1, U) ENDIF ENDIF IF (NB .GT. MN) GOTO 280 C C Test if current BN(N) is 10^LB times the previous BN(N). C IF (BNN .NE. 0.D0 .AND. IBN .GT. IBS + LB) THEN IF (IDB .GE. 5) WRITE (LDB, 6) II, BNN, IBN 6 FORMAT (/'Tentative relation, iteration', I6, 4X, 'BN(N) =', $ F10.6, ' x 10^', I6) C C Compute residual and norm of tentative relation. C DO 220 K = N, 1, -1 T2 = 0.D0 N2 = 0 S(K0) = 0. S(K0+1) = 0. C DO 210 J = 1, N NW = LR - 2 CALL MPEQ (C(1,J,K), R(1,J)) NW = NWS CALL MPMDC (R(1,J), T1, N1) CALL DPMUL (T1, N1, T1, N1, T3, N3) CALL DPADD (T2, N2, T3, N3, T4, N4) T2 = T4 N2 = N4 CALL MPMULX (R(1,J), X(1,J), S(K1)) CALL MPADD (S(K0), S(K1), S(K2)) CALL MPEQ (S(K2), S(K0)) 210 CONTINUE C C If the residual is zero or within tolerance 10^MT of zero, it is a real C relation. Otherwise it was a false alarm. C CALL MPMDC (S(K0), T3, N3) CALL DPDEC (T3, N3, T1, N1) IF (T1 .EQ. 0.D0 .OR. N1 .LE. MT) THEN IF (IDB .GE. 4) THEN CALL DPSQRT (T2, N2, T3, N3) CALL DPDEC (T3, N3, T1, N1) CALL MPMDC (S(K0), T4, N4) CALL DPDEC (T4, N4, T2, N2) WRITE (LDB, 7) K, T1, N1, T2, N2 7 FORMAT ('Relation in column',I4,3X,'Norm =',F10.6, $ ' x 10^',I6/'Residual =',F10.6,' x 10^',I6) ENDIF IQ = 1 GOTO 280 ENDIF 220 CONTINUE C ENDIF C C Test if BN(N) is the same as ITZ iterations ago. C IF (MOD (II, ITZ) .EQ. 0) THEN IF (BNN .EQ. BNZ .AND. IBN .EQ. IBZ) THEN IF (KER(48) .NE. 0) THEN WRITE (LDB, 8) INT (LOG10 (BDX) * (NW + 3)) 8 FORMAT ('*** MPINRZ: Numeric overflow has occurred. Call ', $ 'MPINRX with at least',I8/'digits precision.') IER = 48 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ICS = ISS RETURN ENDIF BNZ = BNN IBZ = IBN ENDIF BNS = BNN IBS = IBN C C Step 3: Update B and C for transformation and then exchange B and C. C I2 = I1 + 1 C C Check if U(i2,i1) can be converted exactly to an integer. The error C number and message are the same as the previous one. C IF (ABS (U(2,I2,I1)) .GE. NW - 1) THEN IF (KER(49) .NE. 0) THEN WRITE (LDB, 8) INT (LOG10 (BDX) * ABS (U(2,I2,I1))) IER = 49 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ICS = ISS RETURN ENDIF CALL MPNINT (U(1,I2,I1), S(K0)) C DO 230 K = 1, N CALL MPMULX (S(K0), B(1,K,I1), S(K1)) CALL MPSUB (B(1,K,I2), S(K1), S(K2)) CALL MPEQ (S(K2), B(1,K,I2)) CALL MPMULX (S(K0), C(1,K,I2), S(K1)) CALL MPADD (C(1,K,I1), S(K1), S(K2)) CALL MPEQ (S(K2), C(1,K,I1)) 230 CONTINUE C DO 240 K = 1, N CALL MPEQ (B(1,K,I1), S(K1)) CALL MPEQ (B(1,K,I2), B(1,K,I1)) CALL MPEQ (S(K1), B(1,K,I2)) CALL MPEQ (C(1,K,I1), S(K1)) CALL MPEQ (C(1,K,I2), C(1,K,I1)) CALL MPEQ (S(K1), C(1,K,I2)) 240 CONTINUE C C Update U for transformation. C DO 250 J = 0, I1 CALL MPMULX (S(K0), U(1,I1,J), S(K1)) CALL MPSUB (U(1,I2,J), S(K1), S(K2)) CALL MPEQ (S(K2), U(1,I2,J)) 250 CONTINUE C C Update BN and U for exchange. C CALL MPEQ (U(1,I2,I1), S(K0)) CALL MPMULX (S(K0), S(K0), S(K1)) CALL MPMULX (S(K1), BN(1,I1), S(K2)) CALL MPADD (BN(1,I2), S(K2), S(K1)) IF (S(K1) .NE. 0. .AND. S(K1+1) .GT. TL) THEN CALL MPDIVX (BN(1,I1), S(K1), S(K2)) CALL MPMULX (BN(1,I2), S(K2), S(K3)) CALL MPEQ (S(K3), BN(1,I2)) CALL MPMULX (S(K0), S(K2), S(K3)) CALL MPEQ (S(K3), U(1,I2,I1)) ELSE CALL MPEQ (BN(1,I1), BN(1,I2)) U(1,I2,I1) = 0. U(2,I2,I1) = 0. ENDIF CALL MPEQ (S(K1), BN(1,I1)) C DO 260 J = 1, I1 - 1 CALL MPEQ (U(1,I1,J), S(K1)) CALL MPEQ (U(1,I2,J), U(1,I1,J)) CALL MPEQ (S(K1), U(1,I2,J)) 260 CONTINUE C S(K1) = 1. S(K1+1) = 0. S(K1+2) = 1. C DO 270 J = I1 + 2, N CALL MPMULX (U(1,J,I1), U(1,I2,I1), S(K2)) CALL MPMULX (S(K0), U(1,I2,I1), S(K3)) CALL MPSUB (S(K1), S(K3), S(K4)) CALL MPMULX (U(1,J,I2), S(K4), S(K3)) CALL MPADD (S(K2), S(K3), S(K4)) CALL MPMULX (S(K0), U(1,J,I2), S(K2)) CALL MPSUB (U(1,J,I1), S(K2), U(1,J,I2)) CALL MPEQ (S(K4), U(1,J,I1)) 270 CONTINUE C GOTO 190 C 280 IF (IDB .GE. 4) WRITE (6, 9) II, TB, NB 9 FORMAT ('No. iterations =',I6/'Max. bound =',1PD15.6, $ ' x 10^',I5) ICS = ISS RETURN END C SUBROUTINE MPLOG (A, AL2, B) C C This computes the natural logarithm of the MP number A and returns the MP C result in B. AL2 is the MP value of Log(2) produced by a prior call to C MPLOG. For extra high levels of precision, use MPLOGX. The last word of C the result is not reliable. Debug output starts with IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 8 * NW + 43 C cells. Max DP scratch space: NW + 6 cells. C C The Taylor series for Log converges much more slowly than that of Exp. C Thus this routine does not employ Taylor series, but instead computes C logarithms by solving Exp (b) = a using the following Newton iteration, C which converges to b: C C x_{k+1} = x_k + [a - Exp (x_k)] / Exp (x_k) C C These iterations are performed with a maximum precision level NW that C is dynamically changed, approximately doubling with each iteration. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION ALT, CL2, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (ALT = 0.693147180559945309D0, $ CL2 = 1.4426950408889633D0, NIT = 3) DIMENSION A(NW+2), AL2(NW+2), B(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) CALL MPDEB ('MPLOG I', A) C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) C IF (IA .LT. 0 .OR. NA .EQ. 0) THEN IF (KER(50) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPLOG: Argument is less than or equal to zero.') IER = 50 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Unless the input is close to 2, Log (2) must have been precomputed. C CALL MPMDC (A, T1, N1) IF (ABS (T1 - 2.D0) .GT. 1D-3 .OR. N1 .NE. 0) THEN CALL MPMDC (AL2, T2, N2) IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2) $ THEN IF (KER(51) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPLOG: LOG (2) must be precomputed.') IER = 51 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C C Check if input is exactly one. C IF (A(1) .EQ. 1. .AND. A(2) .EQ. 0. .AND. A(3) .EQ. 1.) THEN B(1) = 0. B(2) = 0. GOTO 120 ENDIF C N5 = NW + 5 NS = 3 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T2 = NWS MQ = CL2 * LOG (T2) + 1.D0 - RXX C C Compute initial approximation of Log (A). C T1 = LOG (T1) + N1 * ALT CALL MPDMC (T1, 0, B) NW = 3 IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (one greater than powers of two). C DO 110 K = 2, MQ NW = MIN (2 * NW - 2, NWS) + 1 100 CONTINUE CALL MPEXP (B, AL2, S(K0)) CALL MPSUB (A, S(K0), S(K1)) CALL MPDIV (S(K1), S(K0), S(K2)) CALL MPADD (B, S(K2), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) C 120 IF (IDB .GE. 6) CALL MPDEB ('MPLOG O', B) C RETURN END C SUBROUTINE MPLOGX (A, PI, AL2, B) C C This computes the natural logarithm of the MP number A and returns the MP C result in B. PI is the MP value of Pi produced by a prior call to MPPI or C MPPIX. AL2 is the MP value of Log(2) produced by a prior call to MPLOG C or MPLOGX. Before calling MPLOGX, the array in MPCOM5 must be C initialized by calling MPINIX. For modest levels of precision, use MPLOG. C NW should be a power of two. The last three words of the result are not C reliable. Debug output starts with IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 9 * NW + 42 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This uses the following algorithm, which is due to Salamin. If a is C extremely close to 1, use a Taylor series. Otherwise select n such that C z = x 2^n is at least 2^m, where m is the number of bits of desired C precision in the result. Then C C Log(x) = Pi / [2 AGM (1, 4/x)] C DOUBLE PRECISION ALT, CPI, ST, T1, T2, TN DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (MZL = -5, ALT = 0.693147180559945309D0, $ CPI = 3.141592653589793D0) DIMENSION AL2(NW+2), F1(8), F4(8), PI(NW+2), A(NW+4), B(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) CALL MPDEB ('MPLOGX I', A) C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) NCR = 2 ** MCR C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPLOG (A, AL2, B) L1 = 0 L2 = 0 L3 = 0 L4 = 0 GOTO 110 ENDIF C IF (IA .LT. 0 .OR. NA .EQ. 0) THEN C C Input is less than or equal to zero. C IF (KER(52) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPLOGX: Argument is less than or equal to zero.') IER = 52 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if Pi has been precomputed. C CALL MPMDC (PI, T1, N1) IF (N1 .NE. 0 .OR. ABS (T1 - CPI) .GT. RX2) THEN IF (KER(53) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPLOGX: PI must be precomputed.') IER = 53 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Unless the input is 2, Log (2) must have been precomputed. C IF (A(1) .NE. 1. .OR. A(2) .NE. 0. .OR. A(3) .NE. 2.) THEN IT2 = 0 CALL MPMDC (AL2, T2, N2) IF (N2 .NE. - NBT .OR. ABS (T2 * 0.5D0 ** NBT - ALT) .GT. RX2) $ THEN IF (KER(54) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPLOGX: Log (2) must be precomputed.') IER = 54 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ELSE IT2 = 1 ENDIF C C Define sections of the scratch array. C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 F1(1) = 1. F1(2) = 0. F1(3) = 1. F4(1) = 1. F4(2) = 0. F4(3) = 4. C C If argument is 1, the result is zero. If the argument is extremely close C to 1. If so, employ a Taylor's series instead. C CALL MPSUB (A, F1, S(K0)) IF (S(K0) .EQ. 0.) THEN B(1) = 0. B(2) = 0. GOTO 110 ELSEIF (S(K0+1) .LE. MZL) THEN CALL MPEQ (S(K0), S(K1)) CALL MPEQ (S(K1), S(K2)) I1 = 1 IS = 1 TL = S(K0+1) - NW - 1 C 100 I1 = I1 + 1 IS = - IS ST = IS * I1 CALL MPMULX (S(K1), S(K2), S(K3)) CALL MPDIVD (S(K3), ST, 0, S(K2)) CALL MPADD (S(K0), S(K2), S(K3)) CALL MPEQ (S(K3), S(K0)) IF (S(K2+1) .GE. TL) GOTO 100 C CALL MPEQ (S(K0), B) GOTO 110 ENDIF C C If input is exactly 2, set the exponent to a large value. Otherwise C multiply the input by a large power of two. C CALL MPMDC (A, T1, N1) N2 = NBT * (NW / 2 + 2) - N1 TN = N2 IF (IT2 .EQ. 1) THEN CALL MPDMC (1.D0, N2, S(K0)) ELSE CALL MPMULD (A, 1.D0, N2, S(K0)) ENDIF C C Perform AGM iterations. C CALL MPEQ (F1, S(K1)) CALL MPDIVX (F4, S(K0), S(K2)) CALL MPAGMX (S(K1), S(K2)) C C Compute B = Pi / (2 * A), where A is the limit of the AGM iterations. C CALL MPMULD (S(K1), 2.D0, 0, S(K0)) CALL MPDIVX (PI, S(K0), S(K1)) C C If the input was exactly 2, divide by TN. Otherwise subtract TN * Log(2). C IF (IT2 .EQ. 1) THEN CALL MPDIVD (S(K1), TN, 0, S(K0)) ELSE CALL MPMULD (AL2, TN, 0, S(K2)) CALL MPSUB (S(K1), S(K2), S(K0)) ENDIF CALL MPEQ (S(K0), B) C 110 ICS = ISS IF (IDB .GE. 6) CALL MPDEB ('MPLOGX O', B) RETURN END C SUBROUTINE MPMDC (A, B, N) C C This converts the MP number A to the DPE form (B, N), accurate to between C 14 and 17 digits, depending on system. B will be between 1 and BDX. C Debug output starts with IDB = 9. C DOUBLE PRECISION AA, B DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) DIMENSION A(NW+2) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN B = 0.D0 N = 0 RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPMDC I'/(6F12.0)) ENDIF C IF (A(1) .EQ. 0.) THEN B = 0.D0 N = 0 GOTO 100 ENDIF C NA = ABS (A(1)) AA = A(3) IF (NA .GE. 2) AA = AA + RDX * A(4) IF (NA .GE. 3) AA = AA + RX2 * A(5) IF (NA .GE. 4) AA = AA + RDX * RX2 * A(6) C N = NBT * A(2) B = SIGN (AA, DBLE (A(1))) C 100 IF (IDB .GE. 9) WRITE (LDB, 2) B, N 2 FORMAT ('MPMDC O',F10.0,I10) RETURN END C SUBROUTINE MPMMPC (A, B, L, C) C C This converts MP numbers A and B to MPC form in C, i.e. C = A + B i. C L (an input parameter) is the offset between real and imaginary parts in C C. Debug output starts with IDB = 10. C C Max SP space for C: 2 * L cells. C DIMENSION A(NW+2), B(NW+2), C(2*L) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. C(L+1) = 0. C(L+2) = 0. RETURN ENDIF IF (IDB .GE. 10) WRITE (LDB, 1) 1 FORMAT ('MPMMPC') C I1 = SIGN (1., A(1)) N1 = MIN (INT (ABS (A(1))), NW, L - 2) I2 = SIGN (1., B(1)) N2 = MIN (INT (ABS (B(1))), NW, L - 2) C(1) = SIGN (N1, I1) C(L+1) = SIGN (N2, I2) C DO 100 I = 2, N1 + 2 C(I) = A(I) 100 CONTINUE C DO 110 I = 2, N2 + 2 C(L+I) = B(I) 110 CONTINUE C RETURN END C SUBROUTINE MPMOUT (N1, N2, A) C C This produces a compact printout of the N1 x N1 MP array A. It is called C MPINRQ and MPINRZ. It is not indended to be called directly by the user. C DOUBLE PRECISION T1, T2 DIMENSION A(NW+4,N1,N2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS DIMENSION T1(100), I1(100) C IF (IER .NE. 0) RETURN C DO 110 J = 1, N1 WRITE (LDB, 1) J 1 FORMAT ('Row', I3) C DO 100 K = 1, N2 CALL MPMDC (A(1,J,K), T2, M2) CALL DPDEC (T2, M2, T1(K), I1(K)) 100 CONTINUE C WRITE (LDB, 2) (T1(K), I1(K), K = 1, N2) 2 FORMAT (4(F10.6,I6)) 110 CONTINUE C RETURN END C SUBROUTINE MPMPCM (L, A, B, C) C C This converts the MPC number A to its MP real and imaginary parts, i.e. C B = Real (A) and C = Imag (A). L is the offset between real and C imaginary parts in A. Debug output starts with IDB = 10. C C Max SP space for B and C: NW + 2 cells. C DIMENSION A(2*L), B(NW+2), C(NW+2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 10) WRITE (LDB, 1) 1 FORMAT ('MPMPCM') C I1 = SIGN (1., A(1)) N1 = MIN (INT (ABS (A(1))), NW, L - 2) I2 = SIGN (1., A(L+1)) N2 = MIN (INT (ABS (A(L+1))), NW, L - 2) B(1) = SIGN (N1, I1) C(1) = SIGN (N2, I2) C DO 100 I = 2, N1 + 2 B(I) = A(I) 100 CONTINUE C DO 110 I = 2, N2 + 2 C(I) = A(L+I) 110 CONTINUE C RETURN END C SUBROUTINE MPMUL (A, B, C) C C This routine multiplies MP numbers A and B to yield the MP product C. C When one of the arguments has a much higher level of precision than the C other, this routine is slightly more efficient if A has the lower level of C precision. For extra high levels of precision, use MPMULX. Debug output C starts with IDB = 8. C C Max SP space for C: NW + 4 cells. Max DP scratch space: NW + 4 cells. C C This routine returns up to NW mantissa words of the product. If the C complete double-long product of A and B is desired (for example in large C integer applications), then NW must be at least as large as the sum of the C mantissa lengths of A and B. In other words, if the precision levels of A C and B are both 64 words, then NW must be at least 128 words to obtain the C complete double-long product in C. C DOUBLE PRECISION D, T1, T2, T3 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM4/ D(1024) DIMENSION A(NW+2), B(NW+2), C(NW+4) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPMUL I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF C IA = SIGN (1., A(1)) IB = SIGN (1., B(1)) NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) IF (NA .EQ. 0 .OR. NB .EQ. 0) THEN C C One of the inputs is zero -- result is zero. C C(1) = 0. C(2) = 0. GOTO 170 ENDIF IF (NA .EQ. 1 .AND. A(3) .EQ. 1.) THEN C C A is 1 or -1 -- result is B or -B. C C(1) = SIGN (NB, IA * IB) C(2) = A(2) + B(2) C DO 100 I = 3, NB + 2 C(I) = B(I) 100 CONTINUE C GOTO 170 ELSEIF (NB .EQ. 1 .AND. B(3) .EQ. 1.) THEN C C B is 1 or -1 -- result is A or -A. C C(1) = SIGN (NA, IA * IB) C(2) = A(2) + B(2) C DO 110 I = 3, NA + 2 C(I) = A(I) 110 CONTINUE C GOTO 170 ENDIF C NC = MIN (NA + NB, NW) D2 = A(2) + B(2) C DO 120 I = 1, NC + 4 D(I) = 0.D0 120 CONTINUE C C Perform ordinary long multiplication algorithm. Accumulate at most NW + 4 C mantissa words of the product. C DO 150 J = 3, NA + 2 T1 = A(J) J3 = J - 3 N2 = MIN (NB + 2, NW + 4 - J3) C DO 130 I = 3, N2 D(I+J3) = D(I+J3) + T1 * B(I) 130 CONTINUE C C Release carries periodically to avoid overflowing the exact integer C capacity of double precision floating point words in D. C IF (MOD (J - 2, NPR) .EQ. 0) THEN I1 = MAX (3, J - NPR) I2 = N2 + J3 C> CDIR$ IVDEP DO 140 I = I1, I2 T1 = D(I) T2 = INT (RDX * T1) T3 = INT (RDX * T2) D(I) = T1 - BDX * T2 D(I-1) = D(I-1) + (T2 - BDX * T3) D(I-2) = D(I-2) + T3 140 CONTINUE C ENDIF 150 CONTINUE C C If D(2) is nonzero, shift the result one cell right. C IF (D(2) .NE. 0.D0) THEN D2 = D2 + 1. C CDIR$ IVDEP DO 160 I = NC + 4, 3, -1 D(I) = D(I-1) 160 CONTINUE C ENDIF D(1) = SIGN (NC, IA * IB) D(2) = D2 C C Fix up result, since some words may be negative or exceed BDX. C CALL MPNORM (C) C 170 IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 2) (C(I), I = 1, NO) 2 FORMAT ('MPMUL O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPMULD (A, B, N, C) C C This routine multiplies the MP number A by the DPE number (B, N) to yield C the MP product C. Debug output starts with IDB = 9. C C Max SP space for C: NW + 4 cells. Max DP space: NW + 4 cells. C DOUBLE PRECISION B, BB, D DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM3/ S(1024) COMMON /MPCOM4/ D(1024) DIMENSION A(NW+2), C(NW+4), F(8) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPMULD I'/(6F12.0)) WRITE (LDB, 2) B, N 2 FORMAT ('MPMULD I',1PD25.15,I10) ENDIF C C Check for zero inputs. C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) IB = SIGN (1.D0, B) IF (NA .EQ. 0 .OR. B .EQ. 0.D0) THEN C(1) = 0. C(2) = 0. GOTO 140 ENDIF N1 = N / NBT N2 = N - NBT * N1 BB = ABS (B) * 2.D0 ** N2 C C Reduce BB to within 1 and BDX. C IF (BB .GE. BDX) THEN C DO 100 K = 1, 100 BB = RDX * BB IF (BB .LT. BDX) THEN N1 = N1 + K GOTO 120 ENDIF 100 CONTINUE C ELSEIF (BB .LT. 1.D0) THEN C DO 110 K = 1, 100 BB = BDX * BB IF (BB .GE. 1.D0) THEN N1 = N1 - K GOTO 120 ENDIF 110 CONTINUE C ENDIF C C If B cannot be represented exactly in a single mantissa word, use MPMUL. C 120 IF (BB .NE. AINT (BB)) THEN BB = SIGN (BB, B) CALL MPDMC (BB, N1 * NBT, F) CALL MPMUL (F, A, C) GOTO 140 ENDIF C C Perform short multiply operation. C CDIR$ IVDEP DO 130 I = 3, NA + 2 D(I) = BB * A(I) 130 CONTINUE C C Set the exponent and fix up the result. C D(1) = SIGN (NA, IA * IB) D(2) = A(2) + N1 D(NA+3) = 0.D0 D(NA+4) = 0.D0 CALL MPNORM (C) C 140 IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 3) (C(I), I = 1, NO) 3 FORMAT ('MPMULD O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPMULX (A, B, C) C C This routine multiplies MP numbers A and B to yield the MP product C. C Before calling MPMULX, the array in MPCOM5 must be initialized by calling C MPINIX. For modest levels of precision, use MPMUL. NW should be a power C of two. Debug output starts with IDB = 8. C C Max SP space for C: NW + 4 cells. Max DP scratch space: 12 * NW + 6 cells. C The fact that all advanced routines require this amount of DP scratch C space derives from the requirement in this routine, which all of them call. C C This routine returns up to NW mantissa words of the product. If the C complete double-long product of A and B is desired (for example in large C integer applications), then NW must be at least as large as the sum of the C mantissa lengths of A and B. In other words, if the precision levels of A C and B are both 256 words, then NW must be at least 512 words to obtain the C complete double-long product in C. C C This subroutine uses an advanced technique involving the fast Fourier C transform (FFT). For high precision it is significantly faster than the C conventional scheme used in MPMUL. C> C Two machine-dependent parameters are set in this routine: C C ERM Maximum tolerated FFT roundoff error. On IEEE systems ERM = C 0.438D0. It is not necessary to specify ERM for modest levels of C precision -- see comments below. C MBT Number of mantissa bits in double precision data. MBT = 53 on C IEEE systems, and MBT = 48 (i.e. single precision) on Crays. C It is not necessary to specify MBT for modest levels of precision. C DOUBLE PRECISION AN, CL2, D, ERM, T1, T2, T3, T4 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, ERM = 0.438D0, MBT = 53, $ NDB = 22) DIMENSION A(NW+2), B(NW+2), C(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM4/ D(1024) C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPMULX I'/(6F12.0)) NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 1) (B(I), I = 1, NO) ENDIF C IA = SIGN (1., A(1)) IB = SIGN (1., B(1)) NA = MIN (INT (ABS (A(1))), NW) NB = MIN (INT (ABS (B(1))), NW) NCR = 2 ** MCR C IF (NA .EQ. 0 .OR. NB .EQ. 0) THEN C C One of the inputs is zero -- result is zero. C C(1) = 0. C(2) = 0. GOTO 190 ENDIF C C Check if precision level of one of the arguments is too low to justify the C advanced routine. C IF (NA .LE. NCR .OR. NB .LE. NCR) THEN CALL MPMUL (A, B, C) GOTO 190 ENDIF C C Determine N1, the smallest power of two at least as large as NA and NB. C T1 = NA T2 = NB M1 = CL2 * LOG (T1) + 1.D0 - RXX M2 = CL2 * LOG (T2) + 1.D0 - RXX M1 = MAX (M1, M2) N1 = 2 ** M1 M2 = M1 + 2 N2 = 2 * N1 N4 = 2 * N2 N6 = 3 * N2 N8 = 4 * N2 N21 = N2 + 1 N42 = N4 + 2 N63 = N6 + 3 N84 = N8 + 4 C C Place the input data in A and B into separate sections of the scratch C array D. This code also splits the input data into half-sized words. C> CDIR$ IVDEP DO 100 I = 1, NA T1 = A(I+2) T2 = INT (RBX * T1) D(2*I-1) = T2 D(2*I) = T1 - BBX * T2 100 CONTINUE C DO 110 I = 2 * NA + 1, N2 D(I) = 0.D0 110 CONTINUE C> CDIR$ IVDEP DO 120 I = 1, NB T1 = B(I+2) T2 = INT (RBX * T1) D(2*I-1+N42) = T2 D(2*I+N42) = T1 - BBX * T2 120 CONTINUE C DO 130 I = 2 * NB + 1, N2 D(I+N42) = 0.D0 130 CONTINUE C C Set the second half of each input vector in D to zero. C CDIR$ IVDEP DO 140 I = N2 + 1, N4 D(I) = 0.D0 D(I+N42) = 0.D0 140 CONTINUE C C Perform forward real-to-complex FFTs on the two vectors in D. The complex C results are placed in (D(I), I = 1, N4+2) and (D(I), I = N4 + 3, N8 + 4). C CALL MPRCFT (1, M2, D, D(N84+1)) CALL MPRCFT (1, M2, D(N42+1), D(N84+1)) C C Multiply the resulting complex vectors. C CDIR$ IVDEP DO 150 I = 1, N21 T1 = D(I) T2 = D(I+N21) T3 = D(I+N42) T4 = D(I+N63) D(I+N42) = T1 * T3 - T2 * T4 D(I+N63) = T1 * T4 + T2 * T3 150 CONTINUE C C Perform an inverse complex-to-real FFT on the resulting data. C CALL MPCRFT (-1, M2, D(N42+1), D(N84+1)) C C Divide by N8, recombine words and release carries. C NC = MIN (NA + NB, NW) NC1 = MIN (NW + 1, NA + NB - 1) D(1) = SIGN (NC, IA * IB) D(2) = A(2) + B(2) + 1 AN = 1.D0 / N8 T1 = AN * D(N42+1) D(3) = AINT (T1 + 0.5D0) D(NC+3) = 0.D0 D(NC+4) = 0.D0 D(N42+1) = 0.D0 C> CDIR$ IVDEP DO 160 I = 1, NC1 T1 = AN * D(N42+2*I) T2 = AN * D(N42+2*I+1) T3 = AINT (T1 + 0.5D0) T4 = AINT (T2 + 0.5D0) C D(N42+2*I) = ABS (T3 - T1) C D(N42+2*I+1) = ABS (T4 - T2) T1 = INT (RDX * T3) T2 = T3 - BDX * T1 T3 = INT (RDX * T4) T4 = T4 - BDX * T3 D(I+3) = BBX * T2 + T4 D(I+2) = D(I+2) + BBX * T1 + T3 160 CONTINUE C C Find the largest FFT roundoff error. Roundoff error is minimal unless C exceedingly high precision (i.e. over one million digits) is used. Thus C this test may be disabled in normal use. To disable this test, uncomment C the next line of code. Also, if this test is diabled, the two lines of C the previous loop that begin D(N42) may be commented out. C C This code can be used as a rigorous system integrity test. First set C MBT according to the system being used, and then set ERM to be fairly C small, say 0.001 or whatever is somewhat larger than the largest FFT C roundoff error typically encountered for a given precision level on the C computer being used. Enable this test as explained in the previous C paragraph. Then if an anomalously large roundoff error is detected, a C hardware or compiler error has likely occurred. C GOTO 180 T1 = 0.D0 C DO 170 I = 1, 2 * NC1 + 1 IF (D(N42+I) .GT. T1) THEN I1 = I T1 = D(N42+I) ENDIF 170 CONTINUE C C Check if maximum roundoff error exceeds the limit ERM, which is set above. C Also determine the number of fractional bits and how large the error is in C terms of units in the last place (ulp). C IF (T1 .GT. ERM) THEN IF (KER(55) .NE. 0) THEN T2 = AN * D(I1) I2 = CL2 * LOG (T1) + 1.D0 + RXX I3 = CL2 * LOG (T2) + 1.D0 + RXX I4 = MBT + I2 - I3 I5 = T1 * 2 ** I4 + RXX WRITE (LDB, 2) I1, T1, I4, I5 2 FORMAT ('*** MPMULX: Excessive FFT roundoff error',I10,F10.6, $ 2I6) IER = 55 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ENDIF C C Fix up the result. C 180 CALL MPNORM (C) C 190 IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (C(1))), NDB) + 2 WRITE (LDB, 3) (C(I), I = 1, NO) 3 FORMAT ('MPMULX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNINT (A, B) C C This sets B equal to the integer nearest to the MP number A. Debug output C starts with IDB = 8. C C Max SP space for B: NW + 4 cells. Max SP scratch space: NW + 4 cells. C DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) DIMENSION A(NW+2), B(NW+2), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPNINT I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) MA = A(2) IF (NA .EQ. 0) THEN C C A is zero -- result is zero. C B(1) = 0. B(2) = 0. GOTO 110 ENDIF IF (MA .GE. NW) THEN C C A cannot be represented exactly as an integer. C IF (KER(56) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPNINT: Argument is too large.') IER = 56 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C NS = NW + 4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS F(1) = 1. F(2) = -1. F(3) = 0.5D0 * BDX C C Add or subtract 1/2 from the input, depending on its sign. C IF (IA .EQ. 1) THEN CALL MPADD (A, F, S(K0)) ELSE CALL MPSUB (A, F, S(K0)) ENDIF IC = SIGN (1., S(K0)) NC = ABS (S(K0)) MC = S(K0+1) C C Place integer part of S in B. C NB = MIN (MAX (MC + 1, 0), NC) IF (NB .EQ. 0) THEN B(1) = 0. B(2) = 0. ELSE B(1) = SIGN (NB, IC) B(2) = MC B(NB+3) = 0. B(NB+4) = 0. C DO 100 I = 3, NB + 2 B(I) = S(I+K0-1) 100 CONTINUE C ENDIF ICS = ISS C 110 IF (IDB .GE. 8) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPNINT O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNORM (A) C C This converts the MP number in array D of MPCOM4 to the standard C normalized form in A. The MP routines often leave negative numbers or C values exceeding the radix BDX in result arrays, and this fixes them. C MPNORM assumes that two extra mantissa words are input at the end of D. C This reduces precision loss when it is necessary to shift the result to C the left. This routine is not intended to be called directly by the user. C The output is placed in the SP array A. Debug output starts with IDB = 10. C C Max SP space for A: NW + 4 cells. C DOUBLE PRECISION D, R1, S1, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM4/ D(1024) DIMENSION A(NW+4) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF IF (IDB .GE. 10) THEN NO = MIN (INT (ABS (D(1))), NDB) + 4 WRITE (LDB, 1) (D(I), I = 1, NO) 1 FORMAT ('MPNORM I'/(4F18.0)) ENDIF C IA = SIGN (1.D0, D(1)) NA = MIN (INT (ABS (D(1))), NW) IF (NA .EQ. 0) GOTO 170 N4 = NA + 4 A2 = D(2) D(2) = 0.D0 R1 = 2.D0 + 0.125D0 * RDX C> C Try a vectorized fixup loop three times, unless A is very short. This C should handle 99% of the inputs. On scalar computers, it is more C efficient to completely bypass this loop, by uncommenting the next line. C GOTO 120 IF (NA .LE. 8) GOTO 120 C DO 110 K = 1, 3 S1 = 0.D0 C> CDIR$ IVDEP DO 100 I = 3, N4 T1 = INT (D(I) * RDX + R1) - 2.D0 D(I) = D(I) - T1 * BDX D(I-1) = D(I-1) + T1 S1 = S1 + ABS (T1) 100 CONTINUE C IF (S1 .EQ. 0.D0) GOTO 140 110 CONTINUE C C Still not fixed - use recursive loop. This loop is not vectorizable, C but it is guaranteed to complete the job in one pass. C 120 T1 = 0.D0 C> DO 130 I = N4, 3, -1 T2 = T1 + D(I) T1 = INT (T2 * RDX + R1) - 2.D0 D(I) = T2 - T1 * BDX 130 CONTINUE C D(2) = D(2) + T1 C 140 IF (D(2) .NE. 0.) THEN C C The fixup loops above "spilled" a nonzero number into D(2). Shift the C entire number right one cell. The exponent and length of the result C are increased by one. C DO 150 I = N4, 3, -1 A(I) = D(I-1) 150 CONTINUE C NA = MIN (NA + 1, NW) A2 = A2 + 1. ELSE C DO 160 I = 3, N4 A(I) = D(I) 160 CONTINUE C ENDIF C C Perform rounding and truncation. C A(1) = SIGN (NA, IA) A(2) = A2 CALL MPROUN (A) C 170 IF (IDB .GE. 10) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 2) (A(I), I = 1, NO) 2 FORMAT ('MPNORM O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNPWR (A, N, B) C C This computes the N-th power of the MP number A and returns the MP result C in B. When N is zero, 1 is returned. When N is negative, the reciprocal C of A ^ |N| is returned. For extra high levels of precision, use MPNPWX. C Debug output starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 2 * NW + 10 C cells. Max DP scratch space: NW + 5 cells. C C This routine employs the binary method for exponentiation. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22) DIMENSION A(NW+2), B(NW+4), F1(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) N, (A(I), I = 1, NO) 1 FORMAT ('MPNPWR I',I5/(6F12.0)) ENDIF C NA = MIN (INT (ABS (A(1))), NW) IF (NA .EQ. 0) THEN IF (N .GE. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ELSE IF (KER(57) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPNPWR: Argument is zero and N is negative or', $ ' zero.') IER = 57 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C N5 = NW + 5 NS = 2 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 NWS = NW NW = NW + 1 NN = ABS (N) F1(1) = 1. F1(2) = 0. F1(3) = 1. IF (NN .EQ. 0) THEN CALL MPEQ (F1, B) NW = NWS ICS = ISS GOTO 120 ELSEIF (NN .EQ. 1) THEN CALL MPEQ (A, B) GOTO 110 ELSEIF (NN .EQ. 2) THEN CALL MPMUL (A, A, S(K0)) CALL MPEQ (S(K0), B) GOTO 110 ENDIF C C Determine the least integer MN such that 2 ^ MN .GT. NN. C T1 = NN MN = CL2 * LOG (T1) + 1.D0 + RXX CALL MPEQ (F1, B) CALL MPEQ (A, S(K0)) KN = NN C C Compute B ^ N using the binary rule for exponentiation. C DO 100 J = 1, MN KK = KN / 2 IF (KN .NE. 2 * KK) THEN CALL MPMUL (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) ENDIF KN = KK IF (J .LT. MN) THEN CALL MPMUL (S(K0), S(K0), S(K1)) CALL MPEQ (S(K1), S(K0)) ENDIF 100 CONTINUE C C Compute reciprocal if N is negative. C 110 IF (N .LT. 0) THEN CALL MPDIV (F1, B, S(K0)) CALL MPEQ (S(K0), B) ENDIF C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) C 120 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPNPWR O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNPWX (A, N, B) C C This computes the N-th power of the MP number A and returns the MP result C in B. When N is zero, 1 is returned. When N is negative, the reciprocal C of A ^ |N| is returned. Before calling MPNPWX, the array in MPCOM5 must C be initialized by calling MPINIX. For modest levels of precision, use C MPNPWR. NW should be a power of two. The last two words of the result C are not reliable. Debug output starts with IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 4 * NW + 16 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine employs the binary method for exponentiation. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22) DIMENSION A(NW+2), B(NW+4), F1(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) N, (A(I), I = 1, NO) 1 FORMAT ('MPNPWX I',I5/(6F12.0)) ENDIF C NCR = 2 ** MCR NA = MIN (INT (ABS (A(1))), NW) C C Check if precision level of A is too low to justify the advanced routine. C IF (NA .LE. NCR) THEN CALL MPNPWR (A, N, B) GOTO 120 ENDIF IF (NA .EQ. 0) THEN IF (N .GE. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ELSE IF (KER(58) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPNPWX: argument is zero and N is negative or', $ ' zero.') IER = 58 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF ENDIF C N4 = NW + 4 NS = 2 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 NN = ABS (N) F1(1) = 1. F1(2) = 0. F1(3) = 1. IF (NN .EQ. 0) THEN CALL MPEQ (F1, B) ICS = ISS GOTO 120 ELSEIF (NN .EQ. 1) THEN CALL MPEQ (A, B) GOTO 110 ELSEIF (NN .EQ. 2) THEN CALL MPMULX (A, A, B) GOTO 110 ENDIF C C Determine the least integer MN such that 2 ^ MN .GT. NN. C T1 = NN MN = CL2 * LOG (T1) + 1.D0 + RXX CALL MPEQ (F1, B) CALL MPEQ (A, S(K0)) KN = NN C C Compute B ^ N using the binary rule for exponentiation. C DO 100 J = 1, MN KK = KN / 2 IF (KN .NE. 2 * KK) THEN CALL MPMULX (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) ENDIF KN = KK IF (J .LT. MN) THEN CALL MPMULX (S(K0), S(K0), S(K1)) CALL MPEQ (S(K1), S(K0)) ENDIF 100 CONTINUE C C Compute reciprocal if N is negative. C 110 IF (N .LT. 0) THEN CALL MPDIVX (F1, B, S(K0)) CALL MPEQ (S(K0), B) ENDIF ICS = ISS C 120 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPNPWX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNRT (A, N, B) C C This computes the N-th root of the MP number A and returns the MP result C in B. N must be at least one and must not exceed 2 ^ 30. For extra high C levels of precision, use MPNRTX. Debug output starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 6 * NW + 32 C cells. Max DP scratch space: NW + 6 cells. C C This subroutine employs the following Newton-Raphson iteration, which C converges to A ^ (-1/N): C C X_{k+1} = X_k + (X_k / N) * (1 - A * X_k^N) C C The reciprocal of the final approximation to A ^ (-1/N) is the N-th root. C These iterations are performed with a maximum precision level NW that C is dynamically changed, approximately doubling with each iteration. C See the comment about the parameter NIT in MPDIVX. C C When N is large and A is very near one, the following binomial series is C employed instead of the Newton scheme: C C (1 + x)^(1/N) = 1 + x / N + x^2 * (1 - N) / (2! N^2) + ... C DOUBLE PRECISION CL2, T1, T2, TN DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3, $ N30 = 2 ** 30) DIMENSION A(NW+2), B(NW+4), F1(8), F2(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) N, (A(I), I = 1, NO) 1 FORMAT ('MPNRT I',I5/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 140 ENDIF IF (IA .LT. 0) THEN IF (KER(59) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPNRT: Argument is negative.') IER = 59 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF IF (N .LE. 0 .OR. N .GT. N30) THEN IF (KER(60) .NE. 0) THEN WRITE (LDB, 3) N 3 FORMAT ('*** MPNRT: Improper value of N',I10) IER = 60 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C If N = 1, 2 or 3, call MPEQ, MPSQRT or MPCBRT. These are faster. C IF (N .EQ. 1) THEN CALL MPEQ (A, B) GOTO 140 ELSEIF (N .EQ. 2) THEN CALL MPSQRT (A, B) GOTO 140 ELSEIF (N .EQ. 3) THEN CALL MPCBRT (A, B) GOTO 140 ENDIF C N5 = NW + 5 NS = 4 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 NWS = NW F1(1) = 1. F1(2) = 0. F1(3) = 1. C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Check how close A is to 1. C CALL MPSUB (A, F1, S(K0)) IF (S(K0) .EQ. 0.) THEN CALL MPEQ (F1, B) ICS = ISS GOTO 140 ENDIF CALL MPMDC (S(K0), T1, N1) N2 = CL2 * LOG (ABS (T1)) T1 = T1 * 0.5D0 ** N2 N1 = N1 + N2 IF (N1 .LE. -30) THEN T2 = N N2 = CL2 * LOG (T2) + 1.D0 + RXX N3 = - NBT * NW / N1 IF (N3 .LT. 1.25 * N2) THEN C C A is so close to 1 that it is cheaper to use the binomial series. C NW = NW + 1 CALL MPDIVD (S(K0), T2, 0, S(K1)) CALL MPADD (F1, S(K1), S(K2)) K = 0 C 100 K = K + 1 T1 = 1 - K * N T2 = (K + 1) * N CALL MPMULD (S(K1), T1, 0, S(K3)) CALL MPDIVD (S(K3), T2, 0, S(K1)) CALL MPMUL (S(K0), S(K1), S(K3)) CALL MPEQ (S(K3), S(K1)) CALL MPADD (S(K1), S(K2), S(K3)) CALL MPEQ (S(K3), S(K2)) IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. - NW) GOTO 100 C CALL MPEQ (S(K2), B) CALL MPDIV (F1, S(K2), S(K0)) GOTO 130 ENDIF ENDIF C C Compute the initial approximation of A ^ (-1/N). C TN = N CALL MPMDC (A, T1, N1) N2 = - N1 / TN T2 = (T1 * 2.D0 ** (N1 + TN * N2)) ** (- 1.D0 / TN) CALL MPDMC (T2, N2, B) CALL MPDMC (TN, 0, F2) NW = 3 IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (one greater than powers of two). C DO 120 K = 2, MQ NW = MIN (2 * NW - 2, NWS) + 1 110 CONTINUE CALL MPNPWR (B, N, S(K0)) CALL MPMUL (A, S(K0), S(K1)) CALL MPSUB (F1, S(K1), S(K0)) CALL MPMUL (B, S(K0), S(K1)) CALL MPDIVD (S(K1), TN, 0, S(K0)) CALL MPADD (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 110 ENDIF 120 CONTINUE C C Take the reciprocal to give final result. C CALL MPDIV (F1, B, S(K1)) CALL MPEQ (S(K1), B) C C Restore original precision level. C 130 NW = NWS ICS = ISS CALL MPROUN (B) C 140 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 4) (B(I), I = 1, NO) 4 FORMAT ('MPNRT O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPNRTX (A, N, B) C C This computes the N-th root of the MP number A and returns the MP result C in B. N must be at least one and must not exceed 2 ^ 30. Before calling C MPNRTX, the array in MPCOM5 must be initialized by calling MPINIX. For C modest levels of precision, use MPNRT. NW should be a power of two. The C last three words of the result are not reliable. Debug output starts with C IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 7 * NW + 48 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses basically the same Newton iteration algorithm as MPNRT. C In fact, this routine calls MPNRT to obtain an initial approximation. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, T1, T2, TN DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1, $ N30 = 2 ** 30) DIMENSION A(NW+2), B(NW+4), F1(8), F2(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) N, (A(I), I = 1, NO) 1 FORMAT ('MPNRTX I',I5/(6F12.0)) ENDIF C NCR = 2 ** MCR IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 140 ENDIF IF (IA .LT. 0) THEN IF (KER(61) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPNRTX: Argument is negative.') IER = 61 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF IF (N .LE. 0 .OR. N .GT. N30) THEN IF (KER(62) .NE. 0) THEN WRITE (LDB, 3) N 3 FORMAT ('*** MPNRTX: Improper value of N',I10) IER = 62 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPNRT (A, N, B) GOTO 140 ENDIF C C If N = 1, 2 or 3, call MPEQ, MPSQRX or MPCBRX. These are faster. C IF (N .EQ. 1) THEN CALL MPEQ (A, B) GOTO 140 ELSEIF (N .EQ. 2) THEN CALL MPSQRX (A, B) GOTO 140 ELSEIF (N .EQ. 3) THEN CALL MPCBRX (A, B) GOTO 140 ENDIF C N4 = NW + 4 NS = 4 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 NWS = NW F1(1) = 1. F1(2) = 0. F1(3) = 1. C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Check how close A is to 1. C CALL MPSUB (A, F1, S(K0)) IF (S(K0) .EQ. 0.) THEN CALL MPEQ (F1, B) GOTO 130 ENDIF CALL MPMDC (S(K0), T1, N1) N2 = CL2 * LOG (ABS (T1)) T1 = T1 * 0.5D0 ** N2 N1 = N1 + N2 IF (N1 .LE. -30) THEN T2 = N N2 = CL2 * LOG (T2) + 1.D0 + RXX N3 = - NBT * NW / N1 IF (N3 .LT. 1.25 * N2) THEN C C A is so close to 1 that it is cheaper to use the binomial series. C CALL MPDIVD (S(K0), T2, 0, S(K1)) CALL MPADD (F1, S(K1), S(K2)) K = 0 C 100 K = K + 1 T1 = 1 - K * N T2 = (K + 1) * N CALL MPMULD (S(K1), T1, 0, S(K3)) CALL MPDIVD (S(K3), T2, 0, S(K1)) CALL MPMULX (S(K0), S(K1), S(K3)) CALL MPEQ (S(K3), S(K1)) CALL MPADD (S(K1), S(K2), S(K3)) CALL MPEQ (S(K3), S(K2)) IF (S(K1) .NE. 0. .AND. S(K1+1) .GE. - NW) GOTO 100 C CALL MPEQ (S(K2), B) GOTO 130 ENDIF ENDIF C C Compute the initial approximation of A ^ (-1/N). C NW = NCR CALL MPNRT (A, N, S(K0)) CALL MPDIV (F1, S(K0), B) TN = N CALL MPDMC (TN, 0, F2) IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (powers of two). C DO 120 K = MCR + 1, MQ AN = NW NW = MIN (2 * NW, NWS) 110 CONTINUE CALL MPNPWX (B, N, S(K0)) CALL MPMULX (A, S(K0), S(K1)) CALL MPSUB (F1, S(K1), S(K0)) S(K1) = MIN (S(K1), AN) CALL MPMULX (B, S(K0), S(K1)) CALL MPDIVD (S(K1), TN, 0, S(K0)) CALL MPADD (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 110 ENDIF 120 CONTINUE C C Take the reciprocal to give final result. C CALL MPDIVX (F1, B, S(K0)) CALL MPEQ (S(K0), B) C 130 ICS = ISS C 140 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 4) (B(I), I = 1, NO) 4 FORMAT ('MPNRTX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPOUT (IU, A, LA, CS) C C This routine writes the exponent plus LA mantissa digits of the MP number C A to logical unit IU. CS is a scratch array of type CHARACTER*1. CS must C be dimensioned at least LA + 25. The digits of A may span more than one C line. A comma is placed at the end of the last line to denote the end of C the MP number. Here is an example of the output: C C 10 ^ -4 x 3.14159265358979323846264338327950288419716939937510, C C Max SP scratch space: 4 * NW + 22 cells. C DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX CHARACTER*1 CS(LA+25) DIMENSION A(NW+2) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) RETURN C NWS = NW LL = LA / LOG10 (BDX) + 1.D0 NW = MIN (NW, LL) CALL MPOUTC (A, CS, L) NW = NWS L = MIN (L, LA + 20) + 1 CS(L) = ',' WRITE (IU, '(78A1)') (CS(I), I = 1, L) C RETURN END C SUBROUTINE MPOUTC (A, B, N) C C Converts the MP number A into character form in the CHARACTER*1 array B. C N (an output parameter) is the length of the output. In other words, B is C contained in B(1), ..., B(N). The format is analogous to the Fortran C exponential format (E format), except that the exponent is placed first. C Debug output starts with IDB = 7. C C Max CHARACTER*1 space for B: 7.225 * NW + 30 cells. Max SP scratch space: C 4 * NW + 22 cells. C C This routine is called by MPOUT, but it may be directly called by the user C if desired for custom output. Example: C C CHARACTER*1 CX(800) C CALL MPOUTC (A, CX, ND) C WRITE (1, '(20A1/(72A1))') (CX(I), I = 1, ND) C DOUBLE PRECISION AA, AL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX CHARACTER*1 B CHARACTER*16 CA PARAMETER (AL2 = 0.301029995663981195D0, CON = 0.8304820235D0, $ NDB = 22) DIMENSION A(NW+2), B(6*NW+20), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = ' ' N = 0 RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPOUTC I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) N5 = NW + 5 NS = 2 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 NWS = NW NW = NW + 1 F(1) = 1. F(2) = 0. F(3) = 10. C C Determine exact power of ten for exponent. C IF (NA .NE. 0) THEN AA = A(3) IF (NA .GE. 2) AA = AA + RDX * A(4) IF (NA .GE. 3) AA = AA + RX2 * A(5) IF (NA .GE. 4) AA = AA + RDX * RX2 * A(6) T1 = AL2 * NBT * A(2) + LOG10 (AA) IF (T1 .GE. 0.D0) THEN NX = T1 ELSE NX = T1 - 1.D0 ENDIF CALL MPNPWR (F, NX, S(K0)) CALL MPDIV (A, S(K0), S(K1)) C C If we didn't quite get it exactly right, multiply or divide by 10 to fix. C 100 IF (S(K1+1) .LT. 0.) THEN NX = NX - 1 CALL MPMULD (S(K1), 10.D0, 0, S(K0)) CALL MPEQ (S(K0), S(K1)) GOTO 100 ELSEIF (S(K1+2) .GE. 10.) THEN NX = NX + 1 CALL MPDIVD (S(K1), 10.D0, 0, S(K0)) CALL MPEQ (S(K0), S(K1)) GOTO 100 ENDIF S(K1) = ABS (S(K1)) ELSE NX = 0 ENDIF C C Place exponent first instead of at the very end as in Fortran. C B(1) = '1' B(2) = '0' B(3) = ' ' B(4) = '^' WRITE (CA, '(I10)') NX C DO 110 I = 1, 10 B(I+4) = CA(I:I) 110 CONTINUE C B(15) = ' ' B(16) = 'x' B(17) = ' ' C C Insert sign and first digit. C IF (IA .EQ. -1) THEN B(18) = '-' ELSE B(18) = ' ' ENDIF IF (NA .NE. 0) THEN NN = S(K1+2) ELSE NN = 0 ENDIF WRITE (CA, '(I1)') NN B(19) = CA(1:1) B(20) = '.' IX = 20 IF (NA .EQ. 0) GOTO 190 F(3) = NN CALL MPSUB (S(K1), F, S(K0)) IF (S(K0) .EQ. 0) GOTO 190 CALL MPMULD (S(K0), 1.D6, 0, S(K1)) NL = MAX (NW * LOG10 (BDX) / 6.D0 - 1.D0, 1.D0) C C Insert the digits of the remaining words. C DO 130 J = 1, NL IF (S(K1+1) .EQ. 0.) THEN NN = S(K1+2) F(1) = 1. F(3) = NN ELSE F(1) = 0. NN = 0 ENDIF WRITE (CA, '(I6.6)') NN C DO 120 I = 1, 6 B(I+IX) = CA(I:I) 120 CONTINUE C IX = IX + 6 CALL MPSUB (S(K1), F, S(K0)) CALL MPMULD (S(K0), 1.D6, 0, S(K1)) IF (S(K1) .EQ. 0.) GOTO 140 130 CONTINUE C C Check if trailing zeroes should be trimmed. C J = NL + 1 C 140 L = IX IF (B(L) .EQ. '0' .OR. (J .GT. NL .AND. B(L-1) .EQ. '0' .AND. $ B(L-2) .EQ. '0' .AND. B(L-3) .EQ. '0' .AND. B(L-4) .EQ. '0')) $ THEN B(L) = ' ' C DO 150 I = L - 1, 21, -1 IF (B(I) .NE. '0') THEN IX = I GOTO 190 ENDIF B(I) = ' ' 150 CONTINUE C IX = 20 C C Check if trailing nines should be rounded up. C ELSEIF (J .GT. NL .AND. B(L-1) .EQ. '9' .AND. B(L-2) .EQ. '9' $ .AND. B(L-3) .EQ. '9' .AND. B(L-4) .EQ. '9') THEN B(L) = ' ' C DO 160 I = L - 1, 21, -1 IF (B(I) .NE. '9') GOTO 180 B(I) = ' ' 160 CONTINUE C C We have rounded away all digits to the right of the decimal point, and the C digit to the left of the digit is a 9. Set the digit to 1 and increase C the exponent by one. C IX = 20 IF (B(19) .EQ. '9') THEN B(19) = '1' WRITE (CA, '(I10)') NX + 1 C DO 170 I = 1, 10 B(I+4) = CA(I:I) 170 CONTINUE C ELSE CA = B(19) READ (CA, '(I1)') NN WRITE (CA, '(I1)') NN + 1 B(19) = CA(1:1) ENDIF GOTO 190 C 180 CA = B(I) READ (CA, '(I1)') NN WRITE (CA, '(I1)') NN + 1 B(I) = CA(1:1) IX = I ENDIF C 190 N = IX NW = NWS ICS = ISS IF (IDB .GE. 7) THEN NO = MIN (N, 6 * NDB + 20) WRITE (LDB, 2) (B(I), I = 1, NO) 2 FORMAT ('MPOUTC O'/(78A1)) ENDIF RETURN END C SUBROUTINE MPPI (PI) C C This computes Pi to available precision (NW mantissa words). For extra C high levels of precision, use MPPIX. Debug output starts with IDB = 7. C C Max SP space for PI: NW + 4 cells. Max SP scratch space: 7 * NW + 37 C cells. Max DP scratch space: NW + 6 cells. C C The algorithm that is used for computing Pi, which is due to Salamin C and Brent, is as follows: C C Set A_0 = 1, B_0 = 1/Sqrt(2) and D_0 = Sqrt(2) - 1/2. C C Then from k = 1 iterate the following operations: C C A_k = 0.5 * (A_{k-1} + B_{k-1}) C B_k = Sqrt (A_{k-1} * B_{k-1}) C D_k = D_{k-1} - 2^k * (A_k - B_k) ^ 2 C C Then P_k = (A_k + B_k) ^ 2 / D_k converges quadratically to Pi. C In other words, each iteration approximately doubles the number of correct C digits, providing all iterations are done with the maximum precision. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0) DIMENSION F(8), PI(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN PI(1) = 0. PI(2) = 0. RETURN ENDIF C C Perform calculations to one extra word accuracy. C N5 = NW + 5 NS = 5 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 K4 = K3 + N5 NWS = NW NW = NW + 1 C C Determine the number of iterations required for the given precision level. C This formula is good only for this Pi algorithm. C T1 = NWS * LOG10 (BDX) MQ = CL2 * (LOG (T1) - 1.D0) + 1.D0 C C Initialize as above. C S(K0) = 1. S(K0+1) = 0. S(K0+2) = 1. F(1) = 1. F(2) = 0. F(3) = 2. CALL MPSQRT (F, S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K1)) F(2) = -1. F(3) = 0.5D0 * BDX CALL MPSUB (S(K2), F, S(K4)) C C Perform iterations as described above. C DO 100 K = 1, MQ CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMUL (S(K0), S(K1), S(K3)) CALL MPSQRT (S(K3), S(K1)) CALL MPMULD (S(K2), 0.5D0, 0, S(K0)) CALL MPSUB (S(K0), S(K1), S(K2)) CALL MPMUL (S(K2), S(K2), S(K3)) T1 = 2.D0 ** K CALL MPMULD (S(K3), T1, 0, S(K2)) CALL MPSUB (S(K4), S(K2), S(K3)) CALL MPEQ (S(K3), S(K4)) 100 CONTINUE C C Complete computation. C CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMUL (S(K2), S(K2), S(K3)) CALL MPDIV (S(K3), S(K4), S(K2)) CALL MPEQ (S(K2), PI) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (PI) C IF (IDB .GE. 7) CALL MPDEB ('MPPI O', PI) RETURN END C SUBROUTINE MPPIX (PI) C C This computes Pi to available precision (NW mantissa words). Before C calling MPPIX, the array in MPCOM5 must be initialized by calling MPINIX. C For modest levels of precision, use MPPI. NW should be a power of two. C The last three words of the result are not reliable. Debug output starts C with IDB = 7. C C Max SP space for PI: NW + 4 cells. Max SP scratch space: 8 * NW + 38 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses basically the same algorithm as MPPI. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0) DIMENSION F(8), PI(NW+4) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN PI(1) = 0. PI(2) = 0. RETURN ENDIF NCR = 2 ** MCR C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPPI (PI) GOTO 110 ENDIF N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 C C Determine the number of iterations required for the given precision level. C This formula is good only for this Pi algorithm. C T1 = NW * LOG10 (BDX) MQ = CL2 * (LOG (T1) - 1.D0) + 1.D0 C C Initialize as above. C S(K0) = 1. S(K0+1) = 0. S(K0+2) = 1. F(1) = 1. F(2) = 0. F(3) = 2. CALL MPSQRX (F, S(K2)) CALL MPMULD (S(K2), 0.5D0, 0, S(K1)) F(2) = -1. F(3) = 0.5D0 * BDX CALL MPSUB (S(K2), F, S(K4)) C C Perform iterations as described above. C DO 100 K = 1, MQ CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULX (S(K0), S(K1), S(K3)) CALL MPSQRX (S(K3), S(K1)) CALL MPMULD (S(K2), 0.5D0, 0, S(K0)) CALL MPSUB (S(K0), S(K1), S(K2)) CALL MPMULX (S(K2), S(K2), S(K3)) T1 = 2.D0 ** K CALL MPMULD (S(K3), T1, 0, S(K2)) CALL MPSUB (S(K4), S(K2), S(K3)) CALL MPEQ (S(K3), S(K4)) 100 CONTINUE C C Complete computation. C CALL MPADD (S(K0), S(K1), S(K2)) CALL MPMULX (S(K2), S(K2), S(K3)) CALL MPDIVX (S(K3), S(K4), S(K2)) CALL MPEQ (S(K2), PI) ICS = ISS C 110 IF (IDB .GE. 7) CALL MPDEB ('MPPIX O', PI) RETURN END C SUBROUTINE MPPOL (N, L, A, X1, NX, X) C C This finds a real root of the N-th degree polynomial whose MP coefficients C are in A by Newton-Raphson iterations, beginning at the DPE value (X1, NX) C and returns the MP root in X. The N + 1 coefficients a_0, a_1, ..., a_N C are assumed to start in locations A(1), A(L+1), A(2*L+1), etc. For extra C high levels of precision, use MPPOLX. Debug output starts with IDB = 6. C C Max SP space for X: NW + 4 cells. Max SP scratch space: 5 * NW + 25 C cells. Max DP scratch space: NW + 5 cells. C C One requirement for this routine to work is that the desired root is not C a repeated root. If one wishes to apply this routine to find a repeated C root, it is first necessary to reduce the polynomial to one that has only C simple roots. This can be done by performing the Euclidean algorithm in C the ring of polynomials to determine the greatest common divisor Q(t) of C P(t) and P'(t). Here P(t) is the polynomial a_0 + a_1 t + a_2 t^2 + C ... + a_n t^n, and P'(t) is the derivative of P(t). Then R(t) = P(t)/Q(t) C is a polynomial that has only simple roots. C C This routine employs the standard form of the Newton-Raphson iteration: C C X_{k+1} = X_k - P(X_k) / P'(X_k) C C These iterations are performed with a maximum precision level NW that is C dynamically changed, approximately doubling with each iteration. C CHARACTER*8 CX DOUBLE PRECISION T1, X1 DIMENSION A(L,N+1), X(NW+4) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN WRITE (LDB, 1) N 1 FORMAT ('MPPOL I',I4) C DO 100 K = 0, N WRITE (CX, '(I4)') K CALL MPDEB (CX, A(1,K+1)) 100 CONTINUE C WRITE (LDB, 2) X1, NX 2 FORMAT ('MPPOL I',F16.12,' x 10 ^',I6) ENDIF C C Check if the polynomial is proper. C IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN IF (KER(63) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPPOL: Either the first or last input ', $ 'coefficient is zero.') IER = 63 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N5 = NW + 5 NS = 5 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 K2 = K1 + N5 K3 = K2 + N5 K4 = K3 + N5 NWS = NW NW = NW + 1 C C Set the initial value. C CALL MPDMC (X1, NX, S(K0)) NW = 5 TL = -4. L1 = 0 LS = -10 C C Perform MP Newton-Raphson iterations to solve P(x) = 0. C 110 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(64) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPPOL: Iteration limit exceeded.') IER = 64 IF (KER(IER) .EQ. 2) CALL MPABRT NW = NWS ICS = ISS RETURN ENDIF ENDIF C C Compute P(x). C CALL MPEQ (A(1,N+1), S(K1)) C DO 120 K = N - 1, 0, -1 CALL MPMUL (S(K0), S(K1), S(K2)) CALL MPADD (S(K2), A(1,K+1), S(K1)) 120 CONTINUE C C Compute P'(x). C T1 = N CALL MPMULD (A(1,N+1), T1, 0, S(K2)) C DO 130 K = N - 1, 1, -1 CALL MPMUL (S(K0), S(K2), S(K3)) T1 = K CALL MPMULD (A(1,K+1), T1, 0, S(K4)) CALL MPADD (S(K3), S(K4), S(K2)) 130 CONTINUE C C Compute P(x) / P'(x) and update x. C CALL MPDIV (S(K1), S(K2), S(K3)) CALL MPSUB (S(K0), S(K3), S(K4)) C IF (IDB .GE. 7) THEN WRITE (LDB, 5) L1 5 FORMAT ('Iteration',I4) CALL MPDEB ('X', S(K0)) CALL MPDEB ('P(X)', S(K1)) CALL MPDEB ('P''(X)', S(K2)) CALL MPDEB ('CORR', S(K3)) ENDIF CALL MPEQ (S(K4), S(K0)) C C If this was the second iteration at full precision, there is no need to C continue (the adjusted value of x is correct); otherwise repeat. C IF (L1 .EQ. LS + 1) GOTO 140 IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL) GOTO 110 C C Newton iterations have converged to current precision. Increase precision C and continue. C IF (NW .EQ. NWS + 1) GOTO 140 NW = MIN (2 * NW - 2, NWS) + 1 IF (NW .EQ. NWS + 1) LS = L1 TL = 1 - NW IF (IDB .GE. 7) THEN WRITE (LDB, 6) NW 6 FORMAT (6X,'New NW =', I8) ENDIF GOTO 110 C 140 CALL MPEQ (S(K0), X) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (X) C IF (IDB .GE. 6) THEN WRITE (LDB, 7) L1 7 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPPOL O', X) ENDIF RETURN END C SUBROUTINE MPPOLX (N, L, A, X1, NX, X) C C This finds a real root of the N-th degree polynomial whose MP coefficients C are in A by Newton-Raphson iterations, beginning at the DP value (X1, NX) C and returns the MP root in X. The N + 1 coefficients a_0, a_1, ..., a_N C are assumed to start in locations A(1), A(L+1), A(2*L+1), etc. Before C calling MPPOLX, the array in MPCOM5 must be initialized by calling MPINIX. C For modest levels of precision, use MPPOL. NW should be a power of two. C The last three words of the result are not reliable. Debug output starts C with IDB = 5. C C Max SP space for X: NW + 4 cells. Max SP scratch space: 7.5 * NW + 45 C cells. Max DP scratch space: 12 * NW + 6 cells. C C For a discussion of the algorithm and usage, see MPPOL. This routine uses C basically the same Newton iteration algorithm as MPPOL. In fact, this C routine calls MPPOL to obtain an initial approximation. C CHARACTER*8 CX DOUBLE PRECISION T1, X1 DIMENSION A(L,N+1), X(NW+4) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN X(1) = 0. X(2) = 0. RETURN ENDIF IF (IDB .GE. 5) THEN WRITE (LDB, 1) N 1 FORMAT ('MPPOLX I',I4) C DO 100 K = 0, N WRITE (CX, '(I4)') K CALL MPDEB (CX, A(1,K+1)) 100 CONTINUE C WRITE (LDB, 2) X1, NX 2 FORMAT ('MPPOLX I',F16.12,' x 10 ^',I6) ENDIF C C Check if precision level is too low to justify the advanced routine. C NCR = 2 ** MCR IF (NW .LE. NCR) THEN CALL MPPOL (N, L, A, X1, NX, X) L1 = 0 GOTO 150 ENDIF C C Check if the polynomial is proper. C IF (A(1,1) .EQ. 0. .OR. A(1,N+1) .EQ. 0.) THEN IF (KER(65) .NE. 0) THEN WRITE (LDB, 3) 3 FORMAT ('*** MPPOLX: Either the first or last input ', $ 'coefficient is zero.') IER = 65 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N4 = NW + 4 NS = 5 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 K2 = K1 + N4 K3 = K2 + N4 K4 = K3 + N4 NWS = NW C C Compute the initial approximation. C NW = NCR CALL MPPOL (N, L, A, X1, NX, X) CALL MPEQ (X, S(K0)) TL = 2 - NW L1 = 0 LS = -10 C C Perform MP Newton-Raphson iterations to solve P(x) = 0. C 110 L1 = L1 + 1 IF (L1 .EQ. 50) THEN IF (KER(66) .NE. 0) THEN WRITE (LDB, 4) 4 FORMAT ('*** MPPOLX: Iteration limit exceeded.') IER = 66 IF (KER(IER) .EQ. 2) CALL MPABRT NW = NWS ICS = ISS RETURN ENDIF ENDIF C C Compute P(x). C CALL MPEQ (A(1,N+1), S(K1)) C DO 120 K = N - 1, 0, -1 CALL MPMULX (S(K0), S(K1), S(K2)) CALL MPADD (S(K2), A(1,K+1), S(K1)) 120 CONTINUE C C Compute P'(x). C T1 = N CALL MPMULD (A(1,N+1), T1, 0, S(K2)) C DO 130 K = N - 1, 1, -1 CALL MPMULX (S(K0), S(K2), S(K3)) T1 = K CALL MPMULD (A(1,K+1), T1, 0, S(K4)) CALL MPADD (S(K3), S(K4), S(K2)) 130 CONTINUE C C Compute P(x) / P'(x) and update x. C CALL MPDIVX (S(K1), S(K2), S(K3)) CALL MPSUB (S(K0), S(K3), S(K4)) C IF (IDB .GE. 6) THEN WRITE (LDB, 5) L1 5 FORMAT ('Iteration',I4) CALL MPDEB ('X', S(K0)) CALL MPDEB ('P(X)', S(K1)) CALL MPDEB ('P''(X)', S(K2)) CALL MPDEB ('CORR', S(K3)) ENDIF CALL MPEQ (S(K4), S(K0)) C C If this was the second iteration at full precision, there is no need to C continue (the adjusted value of x is correct); otherwise repeat. C IF (L1 .EQ. LS + 1) GOTO 140 IF (S(K3) .NE. 0. .AND. S(K3+1) .GT. TL) GOTO 110 C C Newton iterations have converged to current precision. Increase precision C and continue. C IF (NW .EQ. NWS) GOTO 140 NW = MIN (2 * NW, NWS) IF (NW .EQ. NWS) LS = L1 IF (NW .LE. 32) THEN TL = 2 - NW ELSEIF (NW .LE. 256) THEN TL = 3 - NW ELSE TL = 4 - NW ENDIF IF (IDB .GE. 6) THEN WRITE (LDB, 6) NW 6 FORMAT (6X,'New NW =', I8) ENDIF GOTO 110 C 140 CALL MPEQ (S(K0), X) ICS = ISS C 150 IF (IDB .GE. 5) THEN WRITE (LDB, 7) L1 7 FORMAT ('Iteration count:',I5) CALL MPDEB ('MPPOLX O', X) ENDIF RETURN END C SUBROUTINE MPRAND (A) C> C This returns a pseudo-random MP number A between 0 and 1. This routine C calls the pseudo-random number generator routine MPRANQ in the file below. C Better routines than MPRANQ are available for this purpose on some C computer systems. If so, it is suggested that the call to MPRANQ here be C replaced by a call to its equivalent on the host system. Note, however, C that test no. 55 of the TESTMP test suite will fail if another generator C is used. Debug output starts with IDB = 9. C C Max SP space for A: NW + 4 cells. C DOUBLE PRECISION MPRANQ, SD, S0 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (NDB = 22, S0 = 314159265.D0) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS DIMENSION A(NW+4) SAVE SD DATA SD/S0/ C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF A(1) = NW A(2) = -1. C DO 100 I = 3, NW + 4 A(I) = AINT (BDX * MPRANQ (SD)) 100 CONTINUE C CALL MPROUN (A) C IF (IDB .GE. 9) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPRAND O'/(6F12.0)) ENDIF RETURN END C FUNCTION MPRANQ (SD) C C This routine returns a pseudorandom DP floating number uniformly C distributed between 0 and 1, computed from the seed SD, which is updated C after each reference. The initial value of SD should be an odd whole C number in the range (1, 2 ^ 30). 2 ^ 28 pseudorandom numbers with 30 bits C each are returned before repeating. The same sequence is generated on any C computer system. C DOUBLE PRECISION F7, R30, SD, T1, T2, T30, MPRANQ PARAMETER (F7 = 78125.D0) SAVE R30, T30 DATA R30/0.D0/ C C If this is the first time MPRANQ has been called, compute R30 = 2^(-30) C and T30 = 2^30. This must be done in a loop rather than by merely using C ** in order to insure the results are exact on all systems. C IF (R30 .EQ. 0.D0) THEN R30 = 1.D0 T30 = 1.D0 C DO 100 I = 1, 30 R30 = 0.5D0 * R30 T30 = 2.D0 * T30 100 CONTINUE C ENDIF C C Generate a pseudorandom number using a linear congruential scheme. C T1 = F7 * SD T2 = AINT (R30 * T1) SD = T1 - T30 * T2 MPRANQ = R30 * SD C RETURN END C SUBROUTINE MPRCFT (IS, M, X, Y) C C This performs an N-point real-to-complex FFT, where N = 2^M. X and Y C are double precision arrays. X is both the input and the output data C array, and Y is a scratch array. N real values are input and N/2 + 1 C complex pairs are output, with real and imaginary parts separated by C N/2 + 1 locations. A call to MPRCFT with IS = 1 (or -1) indicates a call C to perform a complex-to-real FFT with positive (or negative) exponentials. C M must be at least three. The arrays X and Y must be dimensioned with C N + 2 cells. Before calling MPRCFT, the U array in MPCOM5 must be C initialized by calling MPINIX. C C In this application, MPRCFT is called by MPMULX. This routine is not C intended to be called directly by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) DIMENSION X(*), Y(*) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM5/ U(1024) C C Set initial parameters. C K = U(1) MX = MOD (K, 64) NU = K / 64 N = 2 ** M N2 = N / 2 N21 = N2 + 1 N4 = N / 4 KU = N / 2 KN = KU + NU C C Check if input parameters are invalid. C IF ((IS .NE. 1 .AND. IS .NE. -1) .OR. M .LT. 3 .OR. M .GT. MX) $ THEN IF (KER(67) .NE. 0) THEN WRITE (LDB, 1) IS, M, MX 1 FORMAT ('*** MPRCFT: either U has not been initialized'/ $ 'or else one of the input parameters is invalid',3I5) IER = 67 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Copy X to Y such that Y(k) = X(2k-1) + i X(2k). C CDIR$ IVDEP DO 100 K = 1, N2 Y(K) = X(2*K-1) Y(K+N2) = X(2*K) 100 CONTINUE C C Perform a normal N/2-point FFT on Y. C CALL MPCFFT (IS, M - 1, Y, X) C C Reconstruct the FFT of X. C X(1) = 2.D0 * (Y(1) + Y(N21)) X(N21+1) = 0.D0 X(N4+1) = 2.D0 * Y(N4+1) X(N4+1+N21) = 2.D0 * IS * Y(N4+N2+1) X(N21) = 2.D0 * (Y(1) - Y(N21)) X(N+2) = 0.D0 C CDIR$ IVDEP DO 110 K = 2, N4 Y11 = Y(K) Y12 = Y(K+N2) Y21 = Y(N2+2-K) Y22 = Y(N+2-K) A1 = Y11 + Y21 A2 = Y11 - Y21 B1 = Y12 + Y22 B2 = Y12 - Y22 U1 = U(K+KU) U2 = IS * U(K+KN) T1 = U1 * B1 + U2 * A2 T2 = - U1 * A2 + U2 * B1 X(K) = A1 + T1 X(K+N21) = B2 + T2 X(N2+2-K) = A1 - T1 X(N+3-K) = -B2 + T2 110 CONTINUE C RETURN END C SUBROUTINE MPROUN (A) C C This performs rounding and truncation of the MP number A. It is called C by MPNORM, and also by other subroutines when the precision level is C reduced by one. It is not intended to be directly called by the user. C C Maximum SP space for A: NW + 4 cells. C C The parameter AMX is the absolute value of the largest exponent word C allowed for MP numbers. C DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (AMX = 2.E6) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) DIMENSION A(NW+4) C IF (IER .NE. 0) THEN A(1) = 0. A(2) = 0. RETURN ENDIF C C Check for initial zeroes. C A2 = A(2) A(2) = 0. IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) N4 = NA + 4 IF (A(3) .EQ. 0.) THEN C C Find the first nonzero word and shift the entire number left. The length C of the result is reduced by the length of the shift. C DO 100 I = 4, N4 IF (A(I) .NE. 0.) GOTO 110 100 CONTINUE C A(1) = 0. A(2) = 0. GOTO 170 C 110 K = I - 3 C CDIR$ IVDEP DO 120 I = 3, N4 - K A(I) = A(I+K) 120 CONTINUE C A2 = A2 - K NA = NA - MAX (K - 2, 0) ENDIF C C Perform rounding depending on IRD. C IF (NA .EQ. NW .AND. IRD .GE. 1) THEN IF (IRD .EQ. 1 .AND. A(NA+3) .GE. 0.5D0 * BDX .OR. IRD .EQ. 2 $ .AND. A(NA+3) .GE. 1.) A(NA+2) = A(NA+2) + 1. C C Release carries as far as necessary due to rounding. C DO 130 I = NA + 2, 3, -1 IF (A(I) .LT. BDX) GOTO 140 A(I) = A(I) - BDX A(I-1) = A(I-1) + 1. 130 CONTINUE C C Release of carries due to rounding continued all the way to the start -- C i.e. number was entirely 9's. C A(3) = A(2) NA = 1 A2 = A2 + 1. ENDIF C 140 IF (A(NA+2) .EQ. 0.) THEN C C At least the last mantissa word is zero. Find the last nonzero word C and adjust the length of the result accordingly. C DO 150 I = NA + 2, 3, -1 IF (A(I) .NE. 0.) GOTO 160 150 CONTINUE C A(1) = 0. A(2) = 0. GOTO 170 C 160 NA = I - 2 ENDIF C C Check for overflow and underflow. C IF (A2 .LT. - AMX) THEN IF (KER(68) .NE. 0) THEN WRITE (LDB, 1) 1 FORMAT ('*** MPROUN: Exponent underflow.') IER = 68 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ELSEIF (A2 .GT. AMX) THEN IF (KER(69) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPROUN: Exponent overflow.') IER = 69 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF ENDIF C C Check for zero. C IF (A(3) .EQ. 0.) THEN A(1) = 0. A(2) = 0. ELSE A(1) = SIGN (NA, IA) A(2) = A2 A(NA+3) = 0. A(NA+4) = 0. ENDIF C 170 RETURN END C SUBROUTINE MPSETP (IA, IB) C C This routine sets the parameter whose name is IA in common MPCOM1 to the C value IB. By using this routine instead of merely including the MPCOM1 C block in the code, a user may eliminate the possibility of confusion with C a variable name in his or her program. IA is of type CHARACTER and IB C is the integer value. C CHARACTER*(*) IA COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IA .EQ. 'NW' .OR. IA .EQ. 'nw') THEN NW = IB ELSEIF (IA .EQ. 'IDB' .OR. IA .EQ. 'idb') THEN IDB = IB ELSEIF (IA .EQ. 'LDB' .OR. IA .EQ. 'ldb') THEN LDB = IB ELSEIF (IA .EQ. 'IER' .OR. IA .EQ. 'ier') THEN IER = IB ELSEIF (IA .EQ. 'MCR' .OR. IA .EQ. 'mcr') THEN MCR = IB ELSEIF (IA .EQ. 'IRD' .OR. IA .EQ. 'ird') THEN IRD = IB ELSEIF (IA .EQ. 'ICS' .OR. IA .EQ. 'ics') THEN ICS = IB ELSEIF (IA .EQ. 'IHS' .OR. IA .EQ. 'ihs') THEN IHS = IB ELSEIF (IA .EQ. 'IMS' .OR. IA .EQ. 'ims') THEN IMS = IB ENDIF C RETURN END C SUBROUTINE MPSORT (N, LA, A, IP) C C This routine sorts the entries of the N-long MP vector A into ascending C order using the quicksort algorithm. The entries of A are assumed to C start at A(1), A(LA+1), A(2*LA+1), etc. The permutation vector that would C sort the vector is returned in IP. Debug output starts with IDB = 7. C C Max integer space for IP: N cells. Max SP scratch space: 2 * NW + 8 cells. C CHARACTER*8 CX DIMENSION A(LA,N), IP(N), IK(50), JK(50) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN C DO 100 I = 1, N IP(I) = I 100 CONTINUE C RETURN ENDIF IF (IDB .GE. 7) THEN WRITE (LDB, 1) N, LA 1 FORMAT ('MPSORT I',2I6) C DO 110 K = 1, N WRITE (CX, '(I4)') K CALL MPDEB (CX, A(1,K)) 110 CONTINUE C ENDIF C N4 = NW + 4 NS = 2 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 C DO 120 I = 1, N IP(I) = I 120 CONTINUE C K = 1 IK(1) = 1 JK(1) = N C 130 I = IK(K) J = JK(K) IQ = I JQ = J IT = (I + J + 1) / 2 L = IP(J) IP(J) = IP(IT) IP(IT) = L CALL MPEQ (A(1,IP(J)), S(K0)) J = J - 1 C 140 DO 150 L = I, J CALL MPCPR (S(K0), A(1,IP(L)), IC) IF (IC .LT. 0) GOTO 160 150 CONTINUE C I = J GOTO 190 C 160 I = L C DO 170 L = J, I, -1 CALL MPCPR (S(K0), A(1,IP(L)), IC) IF (IC .GT. 0) GOTO 180 170 CONTINUE C J = I GOTO 190 C 180 J = L IF (I .GE. J) GOTO 190 L = IP(I) IP(I) = IP(J) IP(J) = L GOTO 140 C 190 CALL MPCPR (S(K0), A(1,IP(I)), IC) IF (IC .GE. 0) GOTO 200 L = IP(JQ) IP(JQ) = IP(I) IP(I) = L C 200 K = K - 1 JZ = 0 IF (J .EQ. IQ) GOTO 210 K = K + 1 JK(K) = J JZ = 1 C 210 I = I + 1 IF (I .EQ. JQ) GOTO 220 K = K + 1 IK(K) = I JK(K) = JQ IF (JZ .EQ. 0) GOTO 220 IF (J - IQ .GE. JQ - I) GOTO 220 IK(K-1) = I JK(K-1) = JQ IK(K) = IQ JK(K) = J C 220 IF (K .GT. 0) GOTO 130 C ICS = ISS IF (IDB .GE. 7) WRITE (6, 2) IP 2 FORMAT ('MPSORT O'/(8I9)) RETURN END C SUBROUTINE MPSQRT (A, B) C C This computes the square root of the MP number A and returns the MP result C in B. For extra high levels of precision, use MPSQRX. Debug output C starts with IDB = 7. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 2 * NW + 10 C cells. Max DP scratch space: NW + 5 cells. C C This subroutine employs the following Newton-Raphson iteration, which C converges to 1 / Sqrt(A): C C X_{k+1} = X_k + (X_k / 2) * (1 - A * X_k^2) C C Multiplying the final approximation to 1 / Sqrt(A) by A gives the square C root. These iterations are performed with a maximum precision level NW that C is dynamically changed, approximately doubling with each iteration. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, T1, T2 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 3) DIMENSION A(NW+2), B(NW+4), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPSQRT I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ENDIF IF (IA .LT. 0.D0) THEN IF (KER(70) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPSQRT: Argument is negative.') IER = 70 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C N5 = NW + 5 NS = 2 * N5 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N5 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Compute the initial approximation of 1 / Sqrt(A). C CALL MPMDC (A, T1, N) N2 = - N / 2 T2 = SQRT (T1 * 2.D0 ** (N + 2 * N2)) T1 = 1.D0 / T2 CALL MPDMC (T1, N2, B) F(1) = 1. F(2) = 0. F(3) = 1. NW = 3 IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (one greater than powers of two). C DO 110 K = 2, MQ NW = MIN (2 * NW - 2, NWS) + 1 100 CONTINUE CALL MPMUL (B, B, S(K0)) CALL MPMUL (A, S(K0), S(K1)) CALL MPSUB (F, S(K1), S(K0)) CALL MPMUL (B, S(K0), S(K1)) CALL MPMULD (S(K1), 0.5D0, 0, S(K0)) CALL MPADD (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Multiply by A to give final result. C CALL MPMUL (A, B, S(K1)) CALL MPEQ (S(K1), B) C C Restore original precision level. C NW = NWS ICS = ISS CALL MPROUN (B) C 120 IF (IDB .GE. 7) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPSQRT O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPSQRX (A, B) C C This computes the cube root of the MP number A and returns the MP result C in B. Before calling MPSQRX, the array in MPCOM5 must be initialized by C calling MPINIX. For modest levels of precision, use MPSQRT. NW should be C a power of two. The last three words of the result are not reliable. C Debug output starts with IDB = 6. C C Max SP space for B: NW + 4 cells. Max SP scratch space: 3 * NW + 18 C cells. Max DP scratch space: 12 * NW + 6 cells. C C This routine uses basically the same Newton iteration algorithm as MPSQRT. C In fact, this routine calls MPSQRT to obtain an initial approximation. C See the comment about the parameter NIT in MPDIVX. C DOUBLE PRECISION CL2, T1 DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX PARAMETER (CL2 = 1.4426950408889633D0, NDB = 22, NIT = 1) DIMENSION A(NW+2), B(NW+4), F(8) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM2/ KER(72) COMMON /MPCOM3/ S(1024) C IF (IER .NE. 0) THEN B(1) = 0. B(2) = 0. RETURN ENDIF IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (A(1))), NDB) + 2 WRITE (LDB, 1) (A(I), I = 1, NO) 1 FORMAT ('MPSQRX I'/(6F12.0)) ENDIF C IA = SIGN (1., A(1)) NA = MIN (INT (ABS (A(1))), NW) NCR = 2 ** MCR C IF (NA .EQ. 0) THEN B(1) = 0. B(2) = 0. GOTO 120 ENDIF IF (IA .LT. 0.D0) THEN IF (KER(71) .NE. 0) THEN WRITE (LDB, 2) 2 FORMAT ('*** MPSQRX: Argument is negative.') IER = 71 IF (KER(IER) .EQ. 2) CALL MPABRT ENDIF RETURN ENDIF C C Check if precision level is too low to justify the advanced routine. C IF (NW .LE. NCR) THEN CALL MPSQRT (A, B) GOTO 120 ENDIF N4 = NW + 4 NS = 2 * N4 ISS = ICS ICS = ICS + NS IHS = MAX (ICS, IHS) IF (ICS - 1 .GT. IMS) CALL MPALER K0 = ISS K1 = K0 + N4 NWS = NW C C Determine the least integer MQ such that 2 ^ MQ .GE. NW. C T1 = NW MQ = CL2 * LOG (T1) + 1.D0 - RXX C C Compute the initial approximation of 1 / Sqrt(A). C NW = NCR CALL MPSQRT (A, S(K0)) CALL MPDIV (S(K0), A, B) F(1) = 1. F(2) = 0. F(3) = 1. IQ = 0 C C Perform the Newton-Raphson iteration described above with a dynamically C changing precision level NW (powers of two). C DO 110 K = MCR + 1, MQ AN = NW NW = MIN (2 * NW, NWS) 100 CONTINUE CALL MPMULX (B, B, S(K0)) CALL MPMULX (A, S(K0), S(K1)) CALL MPSUB (F, S(K1), S(K0)) S(K0) = MIN (S(K0), AN) CALL MPMULX (B, S(K0), S(K1)) CALL MPMULD (S(K1), 0.5D0, 0, S(K0)) CALL MPADD (B, S(K0), S(K1)) CALL MPEQ (S(K1), B) IF (K .EQ. MQ - NIT .AND. IQ .EQ. 0) THEN IQ = 1 GOTO 100 ENDIF 110 CONTINUE C C Multiply by A to give final result. C CALL MPMULX (A, B, S(K1)) CALL MPEQ (S(K1), B) ICS = ISS C 120 IF (IDB .GE. 6) THEN NO = MIN (INT (ABS (B(1))), NDB) + 2 WRITE (LDB, 3) (B(I), I = 1, NO) 3 FORMAT ('MPSQRX O'/(6F12.0)) ENDIF RETURN END C SUBROUTINE MPSUB (A, B, C) C C This routine subtracts MP numbers A and B to yield the MP difference C, C by negating B and adding. Debug output starts with IDB = 9. C C Max SP space for C: NW + 4 cells. C DIMENSION A(NW+2), B(NW+2), C(NW+2) COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS C IF (IER .NE. 0) THEN C(1) = 0. C(2) = 0. RETURN ENDIF IF (IDB .GE. 9) WRITE (LDB, 1) 1 FORMAT ('MPSUB') C C Check if A = B. This is necessary because A and B might be same array, C in which case negating B below won't work. C IF (A(1) .NE. B(1)) GOTO 110 C DO 100 I = 2, INT (ABS (A(1))) + 2 IF (A(I) .NE. B(I)) GOTO 110 100 CONTINUE C C A = B. Result is zero. C C(1) = 0. C(2) = 0. IF (IDB .GE. 9) WRITE (LDB, 2) (C(I), I = 1, 2) 2 FORMAT ('MPSUB O'/2F9.0) GOTO 120 C C Save the sign of B, and then negate B. C 110 B1 = B(1) B(1) = - B1 C C Perform addition and restore the sign of B. C CALL MPADD (A, B, C) B(1) = B1 C 120 RETURN END C SUBROUTINE MPTRAN (N1, N2, X, Y) C C Performs a transpose of the vector X, returning the result in Y. X is C treated as a N1 x N2 complex matrix, and Y is treated as a N2 x N1 complex C matrix. The complex data is assumed stored with real and imaginary parts C separated by N1 x N2 locations. C C This routine is called by MPCFFT. It is not intended to be called directly C by the user. C IMPLICIT DOUBLE PRECISION (A-H, O-Z) PARAMETER (NA = 32, NC = 32) DIMENSION X(2*N1*N2), Y(2*N1*N2), Z(NC,2*NC) C N = N1 * N2 C> C Use different techniques, depending on the system, N1 and N2. For Cray C systems, uncomment the next line. C C GOTO 100 C C This strategy is good for many scalar cache memory computers. The C value of NC (i.e. the size of Z) may have to be changed depending on C how large the cache is. C IF (N1 .LE. NC .OR. N2 .LE. NC) THEN IF (N1 .GE. N2) THEN GOTO 110 ELSE GOTO 130 ENDIF ELSE GOTO 150 ENDIF C C This strategy is best for Cray systems. C 100 IF (N1 .LT. NA .OR. N2 .LT. NA) THEN IF (N1 .GE. N2) THEN GOTO 110 ELSE GOTO 130 ENDIF ELSE GOTO 220 ENDIF C C Scheme 1: Perform a simple transpose in the usual way. C 110 DO 120 J = 0, N2 - 1 J1 = J + 1 J2 = J * N1 + 1 C CDIR$ IVDEP DO 120 I = 0, N1 - 1 Y(I*N2+J1) = X(I+J2) Y(I*N2+J1+N) = X(I+J2+N) 120 CONTINUE C GOTO 260 C C Scheme 2: Perform a simple transpose with the loops reversed. C 130 DO 140 I = 0, N1 - 1 I1 = I * N2 + 1 I2 = I + 1 C CDIR$ IVDEP DO 140 J = 0, N2 - 1 Y(J+I1) = X(J*N1+I2) Y(J+I1+N) = X(J*N1+I2+N) 140 CONTINUE C GOTO 260 C C Scheme 3: Perform a transpose using the intermediate array Z. This gives C better performance than schemes 1 and 2 on certain cache memory systems. C The size of the array Z (i.e. the parameter NC above) may have to be C adjusted for optimal performance. C 150 DO 210 JJ = 0, N2 - 1, NC DO 200 II = 0, N1 - 1, NC C DO 170 J = 1, NC J1 = II + (J - 1 + JJ) * N1 C CDIR$ IVDEP DO 160 I = 1, NC Z(J,I) = X(I+J1) Z(J,I+NC) = X(I+J1+N) 160 CONTINUE C 170 CONTINUE C DO 190 I = 1, NC I1 = JJ + (I - 1 + II) * N2 C CDIR$ IVDEP DO 180 J = 1, NC Y(J+I1) = Z(J,I) Y(J+I1+N) = Z(J,I+NC) 180 CONTINUE C 190 CONTINUE C 200 CONTINUE 210 CONTINUE C GOTO 260 C C Scheme 4: Perform the transpose along diagonals to insure odd strides. C This works well on moderate vector, variable stride computers, when both C N1 and N2 are divisible by reasonably large powers of two (32 or larger on C Cray computers). C 220 N11 = N1 + 1 N21 = N2 + 1 IF (N1 .GE. N2) THEN K1 = N1 K2 = N2 I11 = N1 I12 = 1 I21 = 1 I22 = N2 ELSE K1 = N2 K2 = N1 I11 = 1 I12 = N2 I21 = N1 I22 = 1 ENDIF C DO 230 J = 0, K2 - 1 J1 = J * I11 + 1 J2 = J * I12 + 1 C CDIR$ IVDEP DO 230 I = 0, K2 - 1 - J Y(N21*I+J2) = X(N11*I+J1) Y(N21*I+J2+N) = X(N11*I+J1+N) 230 CONTINUE C DO 240 J = 1, K1 - K2 - 1 J1 = J * I21 + 1 J2 = J * I22 + 1 C CDIR$ IVDEP DO 240 I = 0, K2 - 1 Y(N21*I+J2) = X(N11*I+J1) Y(N21*I+J2+N) = X(N11*I+J1+N) 240 CONTINUE C DO 250 J = K1 - K2, K1 - 1 J1 = J * I21 + 1 J2 = J * I22 + 1 C CDIR$ IVDEP DO 250 I = 0, K1 - 1 - J Y(N21*I+J2) = X(N11*I+J1) Y(N21*I+J2+N) = X(N11*I+J1+N) 250 CONTINUE C 260 RETURN END PROGRAM TESTMP C C This is the test program for DHB's multiprecision computation package C MPFUN (binary version). It exercises most routines and verifies that they C are working properly. If any of these tests fail, it cannot possibly be C due to a bug in DHB's MPFUN package, so it must therefore be due to some C local hardware or compiler problem (smile). C C David H. Bailey May 27, 1992 C DOUBLE PRECISION BBX, BDX, BX2, RBX, RDX, RX2, RXX DOUBLE PRECISION DS, DSUM, T1, X1 CHARACTER*1 Z CHARACTER*80 ZA PARAMETER (MX = 6, NX = 2 ** MX, L = 5, N = 8, N4 = NX + 4, $ LN = L * N, MT = 10 - 6 * NX, NP = 20, $ NS = N4 * (4 * N**2 + 5 * N + 14), NT = 64) DIMENSION AA(L,N), AC(2*L,N), A(N4), AL2(N4), B(N4), DS(NT), $ F1(5), F2(5), IP(NP), IS1(NP), IS2(9), NX1(2), PI(N4), X(2*N4), $ XX(N4,NP), X1(2), Y(2*N4), Z(600) COMMON /MPCOM0/ BBX, BDX, BX2, RBX, RDX, RX2, RXX, NBT, NPR COMMON /MPCOM1/ NW, IDB, LDB, IER, MCR, IRD, ICS, IHS, IMS COMMON /MPCOM3/ S(NS) DATA AA / $ 1., 0., 40., 0., 0., 1., 0., 24., 0., 0., -1., 0., 15., 0., 0., $ -1., 0., 8., 0., 0., 1., 0., 5., 0., 0., 1., 0., 2., 0., 0., $ 0., 0., 0., 0., 0., 1., 0., 1., 0., 0./ DATA AC / $ 1., 0., 40., 0., 0., 5 * 0., 1., 0., 24., 0., 0., 5 * 0., $ -1., 0., 15., 0., 0., 5 * 0., -1., 0., 8., 0., 0., 5 * 0., $ 1., 0., 5., 0., 0., 5 * 0., 1., 0., 2., 0., 0., 5 * 0., $ 0., 0., 0., 0., 0., 5 * 0., 1., 0., 1., 0., 0., 5 * 0./ DATA DS / $ 71647124.D0, 0.D0, 532002022.D0, 520881213.D0, $ 535684389.D0, 466695539.D0, 525576020.D0, 448479226.D0, $ 598587746.D0, 577629931.D0, 544393923.D0, 527030594.D0, $ 550529242.D0, 523320411.D0, 536143302.D0, 516904795.D0, $ 522577789.D0, 501964666.D0, 564046428.D0, 533883779.D0, $ 560037982.D0, 539041558.D0, 485070596.D0, 465190050.D0, $ 534435267.D0, 521869037.D0, 535883606.D0, 516544718.D0, $ 501186251.D0, 490005323.D0, 471471731.D0, 457042260.D0, $ 531664183.D0, 531664183.D0, 525224768.D0, 525224767.D0, $ 573727184.D0, 512972074.D0, 549225360.D0, 497418453.D0, $ 510801511.D0, 520623984.D0, 501266282.D0, 502986625.D0, $ 526887598.D0, 515152633.D0, 470800624.D0, 448276146.D0, $ 501444259.D0, 483347713.D0, 515452421.D0, 585480619.D0, $ 479413814.D0, 549866295.D0, 561015607.D0, 603898762.D0, $ 550269122.D0, 550269122.D0, 529966523.D0, 503319486.D0, $ 92.D0, 92.D0, 2 * 0.D0/ DATA IS1 / $ 20, 1, 11, 10, 16, 5, 17, 12, 15, 13, 9, 4, $ 2, 18, 6, 3, 7, 19, 8, 14/ DATA IS2 / $ 64, 0, 6, 0, 5, 1, 1, 21081, 21080/ C C Initialize. MCR is set to 5 so that the advanced routines can be tested C with reasonably short run times. C NW = NX MCR = 5 IMS = NS CALL MPINIX (MX) C C Test the input/output conversion routines. C KT = 1 ZA = '10 ^ - 50 x - 3. 14159 26535 89793 23846 26433 83279 50288' READ (ZA, '(80A1)') (Z(I), I = 1, 80) CALL MPINPC (Z, 80, A) LS = 9 IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A) WRITE (6, 1) KT 1 FORMAT ('COMPLETED TEST',I3) C KT = 2 ZA ='10 ^ -50 x -3.14159265358979323846264338327950288' CALL MPOUTC (A, Z, NN) NN = MIN (NN, 55) C DO 100 J = 1, NN IF (Z(J) .NE. ZA(J:J)) THEN WRITE (6, 2) KT, (Z(I), I = 1, NN) 2 FORMAT ('TESTMP FAILED ON TEST NO.',I4/'RESULT: ',60A1) GOTO 110 ENDIF 100 CONTINUE C 110 WRITE (6, 1) KT C C Compute 3. ^ (-13). C KT = 3 F1(1) = 1. F1(2) = 0. F1(3) = 3. NN = -13 LS = NW + 2 CALL MPNPWR (F1, NN, A) IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A) WRITE (6, 1) KT C KT = 4 LS = NW CALL MPNPWX (F1, NN, A) IF (DSUM (LS, A) .NE. DS(KT)) CALL DERR (KT, LS, A) WRITE (6, 1) KT C C Compute (4 - i) ^ (-25). C KT = 5 F1(1) = 1. F1(2) = 0. F1(3) = 4. F2(1) = -1. F2(2) = 0. F2(3) = 1. CALL MPMMPC (F1, F2, N4, X) NN = -25 LS = NW + 2 CALL MPCPWR (N4, X, NN, Y) IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT KT = 6 IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1)) WRITE (6, 1) KT C KT = 7 LS = NW CALL MPCPWX (N4, X, NN, Y) IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT KT = 8 IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1)) WRITE (6, 1) KT C C Compute Sqrt (Sqrt (10)). C KT = 9 F1(1) = 1. F1(2) = 0. F1(3) = 10. CALL MPSQRT (F1, A) CALL MPSQRT (A, B) LS = NW + 2 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 10 LS = NW CALL MPSQRX (A, B) IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Cbrt (Sqrt (10)). C KT = 11 CALL MPCBRT (A, B) LS = NW + 2 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 12 LS = NW CALL MPCBRX (A, B) IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute the 10th root of 10. C KT = 13 CALL MPNRT (F1, 10, B) LS = NW + 2 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 14 LS = NW CALL MPNRTX (F1, 10, B) IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute the complex square root of (2., 1.). C KT = 15 F1(1) = 1. F1(2) = 0. F1(3) = 2. F2(1) = 1. F2(2) = 0. F2(3) = 1. CALL MPMMPC (F1, F2, N4, X) CALL MPCSQR (N4, X, Y) LS = NW + 1 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT KT = 16 IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1)) WRITE (6, 1) KT C KT = 17 CALL MPCSQX (N4, X, Y) LS = NW IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT KT = 18 IF (DSUM (LS, Y(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, Y(N4+1)) WRITE (6, 1) KT C C Compute Pi. C KT = 19 CALL MPPI (B) LS = NW + 2 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT CALL MPEQ (B, PI) C KT = 20 LS = NW CALL MPPIX (B) IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Log (2). C KT = 21 F1(1) = 1. F1(2) = 0. F1(3) = 2. CALL MPLOG (F1, AL2, B) LS = NW + 2 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT CALL MPEQ (B, AL2) C KT = 22 CALL MPLOGX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Log (10). C KT = 23 F1(3) = 10. CALL MPLOG (F1, AL2, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 24 CALL MPLOGX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Log (1/4). C KT = 25 F1(2) = -1 F1(3) = 0.25D0 * BDX CALL MPLOG (F1, AL2, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 26 CALL MPLOGX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Exp (1). C KT = 27 F1(1) = 1. F1(2) = 0. F1(3) = 1. CALL MPEXP (F1, AL2, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 28 CALL MPEXPX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Exp (2). C KT = 29 F1(3) = 2. CALL MPEXP (F1, AL2, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 30 CALL MPEXPX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Exp (-5). C KT = 31 F1(1) = -1. F1(3) = 5. CALL MPEXP (F1, AL2, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 32 CALL MPEXPX (F1, PI, AL2, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Cos and Sin of Pi/4. C KT = 33 CALL MPMULD (PI, 0.25D0, 0, A) CALL MPCSSN (A, PI, X, Y) LS = NW + 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 34 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C KT = 35 CALL MPCSSX (A, PI, X, Y) LS = NW IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 36 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C C Compute Cos and Sin of 39/64 Pi. C KT = 37 CALL MPMULD (PI, 0.609375D0, 0, A) CALL MPCSSN (A, PI, X, Y) LS = NW + 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 38 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C KT = 39 CALL MPCSSX (A, PI, X, Y) LS = NW - 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 40 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C C Compute Cos and Sin of -19/64 Pi. C KT = 41 CALL MPMULD (PI, -0.296875D0, 0, A) CALL MPCSSN (A, PI, X, Y) LS = NW + 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 42 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C KT = 43 CALL MPCSSX (A, PI, X, Y) LS = NW - 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 44 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C C Compute inverse Cos and Sin of (1, 1). C KT = 45 F1(1) = 1. F1(2) = 0. F1(3) = 1. F2(1) = 1. F2(2) = 0. F2(3) = 1. CALL MPANG (F1, F2, PI, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 46 CALL MPANGX (F1, F2, PI, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute inverse Cos and Sin of (1, 5). C KT = 47 F2(3) = 5. CALL MPANG (F1, F2, PI, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 48 CALL MPANGX (F1, F2, PI, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute inverse Cos and Sin of (-1, 3). C KT = 49 F1(1) = -1. F2(3) = 3. CALL MPANG (F1, F2, PI, B) LS = NW + 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C KT = 50 CALL MPANGX (F1, F2, PI, B) LS = NW - 1 IF (DSUM (LS, B) .NE. DS(KT)) CALL DERR (KT, LS, B) WRITE (6, 1) KT C C Compute Cosh and Sinh of 0.5. C KT = 51 F1(1) = 1. F1(2) = -1. F1(3) = 0.5D0 * BDX CALL MPCSSH (F1, AL2, X, Y) LS = NW + 1 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 52 IF (DSUM (LS, Y) .NE. DS(KT)) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C KT = 53 CALL MPCSHX (F1, PI, AL2, X, Y) LS = NW - 2 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C KT = 54 IF (ABS (DSUM (LS, Y) - DS(KT)) .GT. 1) CALL DERR (KT, LS, Y) WRITE (6, 1) KT C C Compute the root near x = 1.42 + 0.69i of the polynomial C x^7 + 2 x^5 + 5 x^4 - 8 x^3 - 15 x^2 + 24 x + 40 = 0. C KT = 55 X1(1) = 1.42D0 NX1(1) = 0 X1(2) = 0.69D0 NX1(2) = 0 CALL MPCPOL (N - 1, L, AC, X1, NX1, N4, X) LS = NW + 2 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT KT = 56 IF (DSUM (LS, X(N4+1)) .NE. DS(KT)) CALL DERR (KT, LS, X(N4+1)) WRITE (6, 1) KT C KT = 57 CALL MPCPLX (N - 1, L, AC, X1, NX1, N4, X) LS = NW IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT KT = 58 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C C Compute the real root of the above polynomial near x = -1.34. C KT = 59 T1 = -1.34D0 N1 = 0 CALL MPPOL (N - 1, L, AA, T1, N1, X) LS = NW + 2 IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) CALL MPEQ (X, Y) WRITE (6, 1) KT C KT = 60 CALL MPPOLX (N - 1, L, AA, T1, N1, X) LS = NW IF (DSUM (LS, X) .NE. DS(KT)) CALL DERR (KT, LS, X) WRITE (6, 1) KT C C Recover the above polynomial from the computed value of the root. C KT = 61 CALL MPEQ (Y, XX) C DO 120 K = 2, N CALL MPMUL (Y, XX(1,K-1), XX(1,K)) 120 CONTINUE C DO 140 K = 1, N DO 130 J = 1, L AA(J,K) = 0. 130 CONTINUE 140 CONTINUE C CALL MPINRL (N, NX + 4, XX, 5, MT, L, AA, IQ) IF (DSUM (LN, AA) .NE. DS(KT)) CALL DERR (KT, LN, AA) WRITE (6, 1) KT C KT = 62 C DO 160 K = 1, N DO 150 J = 1, L AA(J,K) = 0. 150 CONTINUE 160 CONTINUE C CALL MPINRX (N, NX + 4, XX, 5, MT, L, AA, IQ) IF (DSUM (LN, AA) .NE. DS(KT)) CALL DERR (KT, LN, AA) WRITE (6, 1) KT C C Sort a pseudo-randomly generated vector. C KT = 63 C DO 170 J = 1, NP CALL MPRAND (XX(1,J)) 170 CONTINUE C CALL MPSORT (NP, N4, XX, IP) IF (ICHK (NP, IP, IS1) .NE. 0) CALL IERR (KT, NP, IP) WRITE (6, 1) KT C C Check if parameters in MPCOM1 are correct. C KT = 64 IF (ICHK (9, NW, IS2) .NE. 0) CALL IERR (KT, 9, NW) WRITE (6, 1) KT C STOP END C FUNCTION DSUM (N, A) DOUBLE PRECISION DSUM, S DIMENSION A(N) C S = 0.D0 C DO 100 I = 1, N S = S + A(I) 100 CONTINUE C DSUM = S RETURN END C SUBROUTINE DERR (N, L, A) DOUBLE PRECISION DSUM DIMENSION A(L) CHARACTER*1 CX(1000) C WRITE (6, 1) N 1 FORMAT ('TESTMP FAILED ON TEST NO.',I4) WRITE (6, 2) (A(I), I = 1, L) 2 FORMAT ('RESULT:'/(6F12.0)) CALL MPOUT (6, A, INT (7.225 * (L - 2)), CX) WRITE (6, 3) DSUM (L, A) 3 FORMAT ('CHECKSUM:', F20.0) RETURN END C FUNCTION ICHK (N, IA, IB) DIMENSION IA(N), IB(N) C IS = 0 C DO 100 I = 1, N IS = IS + ABS (IA(I) - IB(I)) 100 CONTINUE C ICHK = IS RETURN END C SUBROUTINE IERR (N, L, IA) DIMENSION IA(L) C WRITE (6, 1) N 1 FORMAT ('TESTMP FAILED ON TEST NO.',I4) WRITE (6, 2) (IA(I), I = 1, L) 2 FORMAT ('RESULT:'/(8I9)) RETURN END C This is the test program 'testran.f' for TRANSMP. C C David H. Bailey June 10, 1992 C CMP+ PRECISION LEVEL 100 CMP+ MIXED MODE FAST CMP+ OUTPUT PRECISION 56 CMP+ EPSILON 1E-110 C PROGRAM TESTRAN CMP+ IMPLICIT MULTIP REAL (A-H, O-Z) CMP+ MULTIP INTEGER IA, IB, IC CMP+ MULTIP REAL A, B CMP+ MULTIP COMPLEX C, D, E PARAMETER (N = 25) IMPLICIT DOUBLE PRECISION (A-H, O-Z) DOUBLE PRECISION A(N), B(N) DOUBLE COMPLEX C, D, E, DPCMPL C C MP parameter definitions. C PARAMETER (DPEPS = 1D-15, DPPIC = 3.141592653589793D0) C EE = EXP (1.D0+0) WRITE (6, *) DPPIC, EE S = 0.D0 C C Loop with subscripted MP variables. C DO 100 I = 1, N A(I) = 2 * I + 1 B(I) = 2.D0 * A(I) * (A(I) + 1.D0) S = S + B(I) ** 2 100 CONTINUE C WRITE (6, *) S C C An expression with mixed MPI and MPR entities. C IA = S IB = 262144 S = (S + 327.25D0) * MOD (IA, 4 * IB) WRITE (6, *) S C C A complex square root reference. C E = SQRT (DPCMPL (2.D0 * S, S)) WRITE (6, *) E C C External and intrinsic MP function references in expressions. C S = DOT (N, A, B) T = 2.D0 * SQRT (S) ** 2 WRITE (6, *) S, T S = S / 1048576.D0 T = S + 2.D0 * LOG (S) X = 3 + NINT (T) * 5 WRITE (6, *) S, T, X C C Deeply nested expressions and function references. C X = (S + (2 * (S - 5) + 3 * (T - 5))) * EXP (COS (LOG (S))) WRITE (6, *) X C C A "special" subroutine call (computes both cos and sin of S). C CALL DPCSSN (S, X, Y) T = 1.D0 - (X ** 2 + Y ** 2) C C IF-THEN-ELSE construct involving MP variables. C IF (S .GT. 0. .AND. T .LT. DPEPS) THEN WRITE (6, *) T ELSE WRITE (6, *) DPEPS ENDIF C STOP END C C MP function subprogram. C CMP+ MULTIP REAL A, B, DOT, S FUNCTION DOT (N, A, B) DOUBLE PRECISION A(N), B(N), DOT, S C S = 0.D0 C DO 100 I = 1, N S = S + A(I) * B(I) 100 CONTINUE C DOT = S RETURN END C C DP equivalent of special subroutine DPCSSN. C SUBROUTINE DPCSSN (A, X, Y) DOUBLE PRECISION A, X, Y X = COS (A) Y = SIN (A) RETURN END C C DP equivalent is special function DPCMPL. C FUNCTION DPCMPL (A, B) DOUBLE COMPLEX DPCMPL DOUBLE PRECISION A, B DPCMPL = DCMPLX (A, B) RETURN END PROGRAM TRANSMP C C This translates a standard Fortran-77 code input on standard input (unit 5) C to a code that calls DHB's MPFUN multiprecision routines, which is output C on standard output (unit 6). This output program may then be compiled and C linked with the MPFUN library file. C C Version Date: June 30, 1992 C C Author: C C David H. Bailey Telephone: 415-604-4410 C NASA Ames Research Center Facsimile: 415-604-3957 C Mail Stop T045-1 Internet: dbailey@nas.nasa.gov C Moffett Field, CA 94035 C C Restrictions: C C This software has now been approved by NASA for unrestricted distribution. C However, usage of this software is subject to the following: C C 1. This software is offered without warranty of any kind, either expressed C or implied. The author would appreciate, however, any reports of bugs C or other difficulties that may be encountered. C 2. If modifications or enhancements to this software are made to this C software by others, NASA Ames reserves the right to obtain this enhanced C software at no cost and with no restrictions on its usage. C 3. The author and NASA Ames are to be acknowledged in any published paper C based on computations using this software. Accounts of practical C applications or other benefits resulting from this software are of C particular interest. Please send a copy of such papers to the author. C C****************************************************************************** C C The following information is a brief description of this program. For C full details and instructions for usage, see the paper "Automatic C Translation of Fortran to Multiprecision", available from the author. C This program works in conjunction with MPFUN, the author's package of C multiprecision functions. C C This translation program allows one to extend the Fortran-77 language C with the data types MULTIP INTEGER, MULTIP REAL and MULTIP COMPLEX. C These data types can be used for integer, floating point or complex C numbers of an arbitrarily high but pre-specified level of precision. C Variables in the input program may be declared to have one of these C multiprecision types in the output program by placing directives C (special comments) in the input file. In this way, the input file C remains an ANSI Fortran-77 compatible program and can be run at any C time using ordinary arithmetic on any Fortran system for comparison C with the multiprecision equivalent. C C This translator program should run on any Fortran-77 system that supports C recursive subroutine references. On some systems, including Sun and IBM C workstations, two non-standard IMPLICIT AUTOMATIC statements must be C uncommented in this file to permit recursion. These and other instances C of machine-dependent code are marked below with C>. C C Instructions for compiling and testing this program are included in the C readme file that accompanies this code. C C****************************************************************************** C C This is the start of the main program of the translator. In each C subprogram below, C+ delimits common data specifications. Specifications C following the second C+ are for local variables. C* comments delimit C debug printout code. C> comments indicate machine-dependent code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 LIN, ARG(MAR) CHARACTER*16 LINQ, NAMQ, NUMX, UCASE DIMENSION ITAR(MAR), LAR(MAR) C C Start of input program file -- initialize and read first line. C IMM = 1 ITE = 1 MPP = 0 MSS = 0 MXP = 0 IEOF = 0 C* C Uncomment one of the next two lines -- the first for normal use, the C second for debug. C OPEN (11, STATUS = 'SCRATCH') C open (11, file = 'scratch') C* OPEN (12, STATUS = 'SCRATCH') REWIND 11 REWIND 12 READ (5, '(A)', END = 150) LIN LC = 1 L1 = 1 L2 = LNBLK (LIN) LS = L2 NVAR = MINT NAMQ = 'TANH' IQTANH = ITAB (0, 0, NAMQ) C C Start processing a new subprogram. C 100 ISTP = 0 NVAR = MINT IEX = 0 IFL = 0 KDO = 0 LSM = 0 MPA = 0 MPF = 0 MPT = 0 IEND = 0 LINE = ' ' C C Initialize the implicit type table and the special constant usage table. C DO 110 I = 1, 26 IMPL(I) = IMPS(I) 110 CONTINUE C DO 120 I = 1, 5 KCON(I) = 0 120 CONTINUE C C Start reading a new statement. C 130 LN = 0 LCT = LC C 140 CONTINUE LL = L2 - L1 + 1 LINE(LN+1:LN+LL) = LIN(L1:L2) LN = LN + LL READ (5, '(A)', END = 150) LIN LC = LC + 1 L1 = 1 L2 = LNBLK (LIN) IF (LIN(1:1) .EQ. 'C' .OR. LIN(1:1) .EQ. 'c' .OR. L2 .EQ. 0) $ GOTO 160 IF (L2 .GT. 72) THEN WRITE (11, 1) LC 1 FORMAT ('CMP*'/'CMP* Characters past column 72 in line',I6, $ ' are ignored.'/'CMP*') L2 = 72 ENDIF IF (LIN(6:6) .NE. ' ') THEN K1 = 72 - LS IF (K1 .GE. 1) LINE(LN+1:LN+K1) = ' ' LN = LN + K1 L1 = 7 LS = L2 GOTO 140 ENDIF LS = L2 GOTO 160 C C The end of file has been encountered. C 150 IEOF = 1 C C A complete multiline statement has been read. Check if it is a comment. C 160 CONTINUE C C Optionally print out current statement. C* C write (6, *) '%'//line(1:ln)//'%' C* LQ = MIN (16, LN) LINQ = UCASE (LINE(1:LQ)) IF (LN .EQ. 0 .OR. LINQ(1:1) .EQ. 'C') THEN C C Check if this comment is a MP directive. C CALL OUTLIN (0, LN, LINE) IF (LN .GE. 4 .AND. LINQ(1:4) .EQ. 'CMP+') CALL MPDEC (LN) GOTO 240 ENDIF K1 = NBLK (7, LN, LINE) LQ = MIN (K1 + 15, LN) LINQ = UCASE (LINE(K1:LQ)) C C Check if this is an end statement. C IF (LINQ(1:5) .EQ. 'END ') THEN IEND = 1 CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C If the executable portion of this subprogram has already been encountered, C and if this subprogram contains no MP variables, there is no need to check C the line any further. C IF (IEX .NE. 0 .AND. MPT .EQ. 0) THEN CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if this line is a program, subroutine, function or block data C statement. C IF (IPFSB (K1, LN) .NE. 0) GOTO 240 C C At the beginning of a subprogram, one of the above should have been noted. C IF (ISTP .EQ. 0) THEN CALL ERRMES (1, 0) WRITE (6, 2) 2 FORMAT ('PROGRAM, SUBROUTINE, FUNCTION, or BLOCK DATA', $ ' statement is missing.') CALL ABRT ENDIF C C Check if it is an implicit statement. C IF (LINQ(1:8) .EQ. 'IMPLICIT') THEN IF (IEX .NE. 0) GOTO 250 K1 = NBLK (K1 + 8, LN, LINE) CALL IMPLIC (K1, LN) CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if it is a type statement. C 170 IT = NTYPE (K1, LN) IF (IT .NE. 0) THEN IF (IEX .NE. 0) GOTO 250 CALL TYPE (IT, K1, LN) GOTO 240 ENDIF C C Check if it is a parameter statement. C IF (LINQ(1:9) .EQ. 'PARAMETER') THEN IF (IEX .NE. 0) GOTO 250 I1 = ISCAN (K1 + 9, LN, LINE) IF (I1 .GE. 1) THEN K1 = K1 + 9 CALL OUTLIN (2, LN, LINE) CALL PARAM (K1, LN) ELSE CALL OUTLIN (1, LN, LINE) ENDIF GOTO 240 ENDIF C C Check if it is a dimension statement. C IF (LINQ(1:9) .EQ. 'DIMENSION') THEN IF (IEX .NE. 0) GOTO 250 CALL DIMEN (K1 + 9, LN) GOTO 240 ENDIF C C Check if it is a common statement. C IF (LINQ(1:6) .EQ. 'COMMON') THEN IF (IEX .NE. 0) GOTO 250 K1 = K1 + 6 I1 = INDX (K1, LN, '/', LINE) IF (I1 .NE. 0) THEN I2 = INDX (I1 + 1, LN, '/', LINE) IF (I2 .EQ. 0) CALL ERRMES (2, 1) K1 = I2 + 1 ENDIF CALL DIMEN (K1, LN) GOTO 240 ENDIF C C Check if it is an equivalence statement. C IF (LINQ(1:11) .EQ. 'EQUIVALENCE') THEN IF (IEX .NE. 0) GOTO 250 CALL OUTLIN (2, LN, LINE) C C Append '1,' to subscripted MP variables. C K2 = LN CALL FIXSUB (K1 + 11, K2, LN) CALL OUTLIN (1, LN, LINE) WRITE (11, 3) 3 FORMAT ('CMP<') GOTO 240 ENDIF C C Check if it is an external, intrinsic or save statement. No processing is C done for these, except to enter names into the symbol table. C IF (LINQ(1:8) .EQ. 'EXTERNAL' .OR. LINQ(1:9) .EQ. 'INTRINSIC' .OR. $ LINQ(1:5) .EQ. 'SAVE ') THEN IF (IEX .NE. 0) GOTO 250 K2 = K1 - 1 + INDEX (LINE(K1:LN), ' ') I1 = ISCAN (K2 + 1, LN, LINE) CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if this is the start of the executable part of the subprogram. C IF (IEX .EQ. 0) THEN IEX = 1 C C Check if the subprogram name is valid and set its type. The type of a C program or subroutine name is set to 0 (undefined), whereas the type of C a function name is set according to previous implicit or type statements. C IX = ITAB (1, 0, FNAM) IF (IX .LE. IQTANH) THEN CALL ERRMES (3, 0) WRITE (6, 4) 4 FORMAT ('This name may not be used as a subroutine or', $ ' function name.') CALL ABRT ELSEIF (IX .GT. MINT .AND. ISTP .EQ. 3 .AND. KTYP(IX) .GE. 8 $ .AND. KDIM(IX) .NE. -2) THEN CALL ERRMES (4, 0) WRITE (6, 5) 5 FORMAT ('MP function names must be declared with an explicit' $ ' MP type directive'/'immediately preceding the function', $ ' statement.') CALL ABRT ENDIF KDEC(IX) = 1 IF (ISTP .NE. 3) KTYP(IX) = 0 C C Parse the argument list of this subprogram, compare with the subprogram C table, and add it if it is not there. C CALL ARLIST (11, LSAR, SARG, NAR, ITAR, LAR, ARG) CALL CHKARG (11, FNAM, NAR, ITAR, LAR, ARG) C C If any MP variables have been defined, or if this is the main program, C Insert a marker in the temporary file to mark the location of the MP C declarations for INIMP. C IF (MPT .NE. 0 .OR. ISTP .EQ. 1) THEN WRITE (11, 6) 6 FORMAT ('CMP>>>') ENDIF C C If no MP variables have been identified, there is no need to further C analyze the statement. C IF (MPT .EQ. 0) THEN CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF ENDIF C C Check if this is a data statement. C IF (LINQ(1:5) .EQ. 'DATA ') THEN I1 = ISCAN (K1 + 5, LN, LINE) IF (I1 .NE. 0) GOTO 260 CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if this is an endif statement. If so, previous if blocks C generated as translations of elseif statements must be closed. C IF (LINQ(1:5) .EQ. 'ENDIF' .OR. LINQ(1:6) .EQ. 'END IF') THEN IF (IFL .GT. 0) THEN C DO 180 I = 1, IFL WRITE (11, 7) 7 FORMAT (6X,'ENDIF') 180 CONTINUE C IFL = 0 ENDIF CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Nothing needs to be processed for these non-executable statements. C IF (LINQ(1:6) .EQ. 'ELSE ' .OR. LINQ(1:6) .EQ. 'ENDDO ' .OR. $ LINQ(1:7) .EQ. 'END DO ' .OR. LINQ(1:8) .EQ. 'CONTINUE' .OR. $ LINQ(1:6) .EQ. 'FORMAT') THEN CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Nothing needs to be processed for these executable statements. C IF (LINQ(1:5) .EQ. 'CLOSE' .OR. LINQ(1:5) .EQ. 'GOTO ' .OR. $ LINQ(1:4) .EQ. 'OPEN' .OR. LINQ(1:5) .EQ. 'STOP ' .OR. $ LINQ(1:9) .EQ. 'BACKSPACE' .OR. LINQ(1:7) .EQ. 'ENDFILE' .OR. $ LINQ(1:7) .EQ. 'INQUIRE' .OR. LINQ(1:6) .EQ. 'RETURN' .OR. $ LINQ(1:6) .EQ. 'REWIND') THEN CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if the statement is a DO statement. If so, place the DO terminal C number in the IDON table. C IF (LINQ(1:3) .EQ. 'DO ') THEN K1 = NBLK (K1 + 3, LN, LINE) I1 = ISCAN (K1, LN, LINE) IF (I1 .NE. 0) GOTO 260 IF (INDEX (DIG, LINE(K1:K1)) .NE. 0) THEN K2 = INDEX (LINE(K1:LN), ' ') IF (K2 .EQ. 0) CALL ERRMES (5, 1) K2 = K1 - 1 + K2 NUMX = LINE(K1:K2) READ (NUMX, '(BN,I16)', ERR = 270) K KDO = KDO + 1 IF (KDO .GT. NDO) THEN CALL ERRMES (6, 0) WRITE (6, 8) 8 FORMAT ('Too many DO statements in this subprogram.') CALL ABRT ENDIF IDON(KDO) = K ENDIF CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Check if statement has any MP variables. If not, there is no need for C any further analysis. C I1 = ISCAN (K1, LN, LINE) IF (I1 .EQ. 0) THEN CALL OUTLIN (1, LN, LINE) GOTO 240 ENDIF C C Output original statement as a comment. C CALL OUTLIN (2, LN, LINE) C C Check if a line number is presesnt. If so, output as a continue statement. C READ (LINE(1:5), '(BN,I5)', ERR = 270) K IF (K .LT. 0 .OR. K .GE. 10000) GOTO 270 IF (K .NE. 0) THEN C DO 190 I = 1, KDO IF (K .EQ. IDON(I)) THEN CALL ERRMES (7, 0) WRITE (6, 9) 9 FORMAT ('MP variables may not appear in the terminal line', $ ' of a DO loop.') CALL ABRT ENDIF 190 CONTINUE C WRITE (11, 10) K 10 FORMAT (I5,' CONTINUE') ENDIF C C Check if this is a logical if or elseif statement with MP variables. C IF (LINQ(1:2) .EQ. 'IF') THEN K3 = NBLK (K1 + 2, LN, LINE) IF (LINE(K3:K3) .NE. '(') GOTO 200 CALL IFST (IFL, 1, K3, LN) GOTO 210 ELSEIF (LINQ(1:6) .EQ. 'ELSEIF') THEN K3 = NBLK (K1 + 6, LN, LINE) CALL IFST (IFL, 2, K3, LN) GOTO 210 ELSEIF (LINQ(1:7) .EQ. 'ELSE IF') THEN K3 = NBLK (K1 + 7, LN, LINE) CALL IFST (IFL, 2, K3, LN) GOTO 210 ENDIF C C Fix subscripts of MP variables and change names of special constants. C 200 K2 = LN CALL FIXSUB (K1, K2, LN) C C Process other kinds of MP executable statements. C CALL EXEC (K1, LN) C C Insert a comment to mark the end of the translation of the MP executable C statement. C 210 WRITE (11, 3) C C Check if the itmp table is properly zeroed. If not, one of the routines C dealing with MP statements erred. C DO 230 J = 1, NTYP DO 220 I = 1, 9 IF (ITMP(I,J) .NE. 0) THEN CALL ERRMES (8, 0) WRITE (6, 11) CTM(J), I 11 FORMAT ('Translator error: active temporary: MP',A1,I1/ $ 'Please contact the author.') CALL ABRT ENDIF 220 CONTINUE 230 CONTINUE C C If this is an end statement, copy the scratch file to the output file, C inserting MP declarations at the marker. C 240 IF (IEND .EQ. 1) THEN CALL COPY IF (IEOF .EQ. 1) STOP GOTO 100 ELSE IF (IEOF .EQ. 1) THEN IF (ISTP .EQ. 0) STOP CALL ERRMES (9, 0) WRITE (6, 12) 12 FORMAT ('The last line of the file was not an END statement.') CALL ABRT ENDIF GOTO 130 ENDIF C 250 CALL ERRMES (10, 0) WRITE (6, 13) 13 FORMAT ('A declarative statement may not appear after an', $ ' executable statement.') CALL ABRT C 260 CALL ERRMES (11, 0) WRITE (6, 14) 14 FORMAT ('MP variables may not appear in this statement.') CALL ABRT C 270 CALL ERRMES (12, 0) WRITE (6, 15) 15 FORMAT ('Syntax error in line number.') CALL ABRT C STOP END C BLOCK DATA C C This sets all data in common. Here is a brief description of these C variables and arrays, in alphabetical order. C C ALPL Lower case alphabet. C ALPU Upper case alphabet. C CTM Table of one-character type abbreviations. C CTP Table of two-character type abbreviations. C DEL Standard Fortran delimiters. C DIG The ten digits. C EPS The mantissa and exponent of the current epsilon, in character form. C FNAM The function name, in function subprograms. C IDON DO line number table. C IEX 1 if the executable portion of the subprogram has been encountered. C IMM Mixed mode option (0:FAST, 1:SAFE). C IMPL Implicit type definition table. C IMPS Default implicit type definitions. C ISTP Type of subprogram (1:PROGRAM, 2:SUBROUTINE, 3:FUNCTION, 4: BLOCK D) C ITE Type error option (0:OFF, 1:ON). C ITMP MP temporary usage table. C KCON Special constant usage table. C KDEC MP variable declaration table. C KDIM Dimension and misc. information for names in VAR: C -3 Special constant or parameter. C -2 MP function name (within its defining subprogram). C -1 Function name. C 0 Scalar variable. C 1 Dimensioned variable. C 2-10 Indicates number of dimensions (not yet implemented). C KDO Number of entries in DO number table. C KEYW Table of Fortran keywords. C KOP Operator precedence table. C KSTP Table of types of subroutine argument lists. C KTYP Types of variables in VAR: C -1 Dependent on argument (for intrinsic function names) C 0 Undefined C 1 Integer C 2 Real C 3 Double Precision C 4 Complex C 5 Double Complex C 6 Character C 7 Logical C 8 MP Integer C 9 MP Real C 10 MP Complex C LCT Current line count. C LEP Lengths of epsilon strings. C LINE Current extended working line read from file. C LOP Lengths of operators in LOPR and UOPR. C LOPR Lower case operators. C LSAR Length of subroutine argument list. C LSM Longest numeric string in current subprogram. C LVAR Lengths of the names in VAR. C MPA Number of MP parameters in current subprogram. C MPLC Table of implicit/explicit status of names in VAR. C MPP Current output precision level. C MPT Set to 1 if an MP variable has been encountered in subprogram. C MSS Scratch space. C MXP Maximum precision level in words. C NARS Table of number of arguments in argument list array KSTP. C NSUB Number of subprograms encountered. C NVAR Number of variables defined in current subprogram (including C standard and MP intrinsic names). C SARG Argument list of current subprogram. C SNAM Table of subroutine names. C UOPR Upper case operators. C VAR Table of variable names for current subprogram. C C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ PARAMETER (NP1 = MVAR - MINT, NPC = 5, NPI = 36, NPF = 6, NPS = 2) DATA IDON /NDO * 0/ DATA IMPL /26 * 0/ DATA IMPS /8 * 2, 6 * 1, 12 * 2/ DATA KDEC /MINT * 1, NP1 * 0/ DATA KDIM /10 * -3, 44 * -1, NP1 * 0/ DATA KTYP /1, 4 * 3, 1, 4 * 9, 3 * -1, 4, 4 * -1, 6, 4, 3 * -1, 3, $ 5, -1, 5, 5, -1, 4 * 1, 6 * -1, 2, 6 * -1, 8, 10, 4 * 9, 2 * 9, $ NP1 * 0/ DATA LVAR /10 * 5, 3, 4, 4, 5, 5, 4, 4, 5, 4, 5, 5, 3, 4, 4, 6, 3, $ 5, 5, 3, 5, 5, 3, 3, 3, 5, 3, 3, 3, 4, 4, 4, 3, 4, 4, 3, 4, 5, $ 6, 6, 6, 5, 6, 6, 6, NP1 * 0/ DATA KOP /1, 6, 6, 8, 7, 7, 5, 5, 5, 5, 5, 5, 3, 4/ DATA LOP /1, 1, 1, 2, 1, 1, 4, 4, 4, 4, 4, 4, 4, 5/ DATA LEP /2 * 0/ DATA MPLC /NPC * 0, NPC * 1, NPI * 1, NPF * 0, NPS * 1, NP1 * 1/ DATA ALPL /'abcdefghijklmnopqrstuvwxyz'/ DATA ALPU /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA DEL /' ,().=+-*/'/ DATA DIG /'0123456789'/ DATA CTM /'I', 'R', 'D', 'C', 'X', 'A', 'L', 'J', 'M', 'Z'/ DATA CTP /'IN', 'SP', 'DP', 'CO', 'DC', 'CH', 'LO', 'MPI', 'MPR', $ 'MPC'/ DATA EPS /2 * ' '/ DATA KEYW/ $ 'BACKSPACE', 'BLOCK', 'CALL', 'CHARACTER', 'CLOSE', 'COMMON', $ 'COMPLEX', 'CONTINUE', 'DATA', 'DIMENSION', 'DO', 'DOUBLE', $ 'ELSE', 'ELSEIF', 'END', 'ENDFILE', 'ENDIF', 'ENTRY', $ 'EQUIVALENCE', 'EXTERNAL', 'FORMAT', 'FUNCTION', 'GO', 'GOTO', $ 'IF', 'IMPLICIT', 'INQUIRE', 'INTEGER', 'INTRINSIC', 'LOGICAL', $ 'OPEN', 'PARAMETER', 'PRECISION', 'PRINT', 'PROGRAM', 'READ', $ 'REAL', 'RETURN', 'REWIND', 'SAVE', 'STOP', 'SUBROUTINE', $ 'THEN', 'TO', 'WRITE'/ DATA LOPR /'=', '+', '-', '**', '*', '/', '.eq.', '.ne.', '.gt.', $ '.lt.', '.ge.', '.le.', '.or.', '.and.'/ DATA SFUN/ $ 'ALOG', 'ALOG10', 'AMAX0', 'AMAX1', 'AMIN0', 'AMIN1', 'AMOD', $ 'CABS', 'CCOS', 'CEXP', 'CLOG', 'CSIN', 'CSQRT', 'DABS', $ 'DACOS', 'DASIN', 'DATAN', 'DATAN2', 'DCOS', 'DCOSH', 'DCOSH', $ 'DDIM', 'DEXP', 'DIM', 'DINT', 'DLOG', 'DLOG10', 'DMAX1', $ 'DMIN1', 'DMOD', 'DNINT', 'DPROD', 'DSIGN', 'DSIN', 'DSINH', $ 'DSQRT', 'DTAN', 'DTANH', 'FLOAT', 'IABS', 'IDIM', 'IDINT', $ 'IDNINT','IFIX', 'ISIGN', 'MAX0', 'MAX1', 'MIN0', 'MIN1', $ 'SNGL'/ DATA VAR / $ 'MPNWP', 'DPEPS', 'DPL02', 'DPL10', 'DPPIC', 'MPNWQ', 'MPEPS', $ 'MPL02', 'MPL10', 'MPPIC', $ 'ABS', 'ACOS', 'AINT', 'AIMAG', 'ANINT', 'ASIN', 'ATAN', $ 'ATAN2', 'CHAR', 'CMPLX', 'CONJG', 'COS', 'COSH', 'DBLE', $ 'DCMPLX', 'DIM', 'DIMAG', 'DREAL', 'EXP', 'ICHAR', 'INDEX', $ 'INT', 'LEN', 'LOG', 'LOG10', 'MAX', 'MIN', 'MOD', 'NINT', $ 'REAL', 'SIGN', 'SIN', 'SINH', 'SQRT', 'TAN', 'TANH', $ 'MPINT', 'DPCMPL', 'DPIMAG', 'DPREAL', 'DPNRT', 'DPRAND', $ 'DPCSSN', 'DPCSSH', NP1 * ' '/ DATA UOPR /'=', '+', '-', '**', '*', '/', '.EQ.', '.NE.', '.GT.', $ '.LT.', '.GE.', '.LE.', '.OR.', '.AND.'/ END C SUBROUTINE ABRT C> C This terminates execution. For debug purposes it may be preferable to C replace the standard STOP with a call to a system routine that produces C a traceback. C C TRACBK is a traceback routine for SGI workstations. The C code for this C routine is available from the author. C C CALL TRACBK C STOP END C SUBROUTINE ARLIST (LU, LA, LINA, NAR, ITAR, LAR, ARG) C C This processes an argument list in LINA, which has length LA. Any C expressions in any argument are first processed with subroutine EXPRES. C The resulting argument list (NAR elements) is placed in ARG, with types C in ITAR and lengths in ARG. LU is the logical unit number of output code. C C> Uncomment this line on Sun and IBM worksations. C C IMPLICIT AUTOMATIC (A-Z) C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA, LINB CHARACTER*80 ARG(MAR), ARGX DIMENSION ITAR(MAR), LAR(MAR) C* C write (lu, *) 'enter arlist' C write (lu, *) '%'//lina(1:la)//'%' C* K1 = 1 NAR = 0 IEND = 0 IF (LA .EQ. 0) GOTO 120 C 100 IF (K1 .GT. LA) CALL ERRMES (13, 1) K1 = NBLK (K1, LA, LINA) IF (K1 .EQ. 0) CALL ERRMES (14, 1) K2 = MATCH (1, K1, LA, LINA) IF (K2 .EQ. 0) THEN K2 = LA + 1 IEND = 1 ENDIF K2 = K2 - 1 LB = K2 - K1 + 1 LINB(1:LB) = LINA(K1:K2) C C Evaluate the expression with EXPRES after setting the mixed mode option C to FAST, except if this is a parameter statement or an intrinsic function C reference. C IMS = IMM IF (LU .NE. 12 .AND. IMM .NE. 2) IMM = 0 CALL EXPRES (LU, LB, LINB, ITPX, LX, ARGX) IMM = IMS C C Add this argument to the list. C 110 NAR = NAR + 1 IF (NAR .GT. MAR) THEN CALL ERRMES (15, 0) WRITE (6, 1) 1 FORMAT ('List has too many arguments.') CALL ABRT ENDIF ITAR(NAR) = ITPX LAR(NAR) = LX ARG(NAR)(1:LX) = ARGX(1:LX) K1 = K2 + 2 IF (IEND .EQ. 0) GOTO 100 C 120 CONTINUE C* C write (lu, *) 'exit arlist args:' C do 111 i = 1, nar C write (lu, *) '%'//arg(i)(1:lar(i))//'%' C 111 continue C* RETURN END C SUBROUTINE ASST (K1, LN) C C This processes MP assignment statements. K1 and LN are the indices of the C first and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*80 ARGX C C Evaluate the entire statement as an expression. C LA = LN - K1 + 1 LINA(1:LA) = LINE(K1:LN) CALL EXPRES (11, LA, LINA, ITPX, LX, ARGX) C C Check if the final result of evaluation of the expression is non-empty. C If so, then the last operation was not an equal operation, and thus the C statement is not a valid assignment statement. C IF (LX .NE. 0) THEN CALL ERRMES (16, 0) WRITE (6, 1) 1 FORMAT ('This is not a valid MP assignment statement.') CALL ABRT ENDIF C RETURN END C SUBROUTINE CALLST (K1, LN) C C This processes MP call statements. K1 and LN are the indices of the C first (after 'call') and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA, LINB CHARACTER*80 ARG(MAR) CHARACTER*16 NAMQ, NAMX DIMENSION ITAR(MAR), LAR(MAR) CHARACTER*4 TMP1 C C Identify subroutine name. C I1 = INDX (K1, LN, '(', LINE) L1 = MIN (I1 - K1, 16) NAMX = LINE(K1:K1+L1-1) IX = ITAB (0, 0, NAMX) IF (IX .EQ. 0) THEN CALL ERRMES (17, 0) WRITE (6, 1) NAMX 1 FORMAT ('This Fortran keyword may not CALLed: ',A) CALL ABRT ENDIF IF (IX .GT. MINT) KTYP(IX) = 0 LINA(1:11) = ' CALL ' ISS = 0 C C Determine if this is one of the special DP subroutine names. C NAMQ = 'DPCSSN' IQ1 = ITAB (0, 0, NAMQ) NAMQ = 'DPCSSH' IQ2 = ITAB (0, 0, NAMQ) IF (IX .EQ. IQ1) THEN KCON(5) = 1 LINA(12:17) = 'MPCSSN' LA = 17 ISS = 1 ELSEIF (IX .EQ. IQ2) THEN KCON(3) = 1 LINA(12:17) = 'MPCSSH' LA = 17 ISS = 2 ELSE LINA(12:L1+11) = NAMX(1:L1) LA = L1 + 11 ENDIF C LINA(LA+1:LA+1) = '(' LA = LA + 1 C C Identify and process list of arguments. C I2 = MATCH (0, I1 + 1, LN, LINE) IF (I2 .NE. LN) CALL ERRMES (18, 1) LB = LN - I1 - 1 IF (LB .EQ. 0) THEN LA = LA + 2 ELSE LINB(1:LB) = LINE(I1+1:LN-1) ENDIF CALL ARLIST (11, LB, LINB, NAR, ITAR, LAR, ARG) C C Check the argument list with the subprogram table. C IF (ISS .EQ. 0) CALL CHKARG (11, NAMX, NAR, ITAR, LAR, ARG) C C Change the argument list if this is a special DP subroutine. C IF (ISS .EQ. 1) THEN IF (NAR .NE. 3) GOTO 120 NAR = 4 ITAR(4) = ITAR(3) LAR(4) = LAR(3) ARG(4) = ARG(3) ITAR(3) = ITAR(2) LAR(3) = LAR(2) ARG(3) = ARG(2) ITAR(2) = 9 LAR(2) = 5 ARG(2) = 'MPPIC' ELSEIF (ISS .EQ. 2) THEN IF (NAR .NE. 3) GOTO 120 NAR = 4 ITAR(4) = ITAR(3) LAR(4) = LAR(3) ARG(4) = ARG(3) ITAR(3) = ITAR(2) LAR(3) = LAR(2) ARG(3) = ARG(2) ITAR(2) = 9 LAR(2) = 5 ARG(2) = 'MPL02' ENDIF C C Append the argument list. C DO 100 J = 1, NAR L1 = LAR(J) LINA(LA+1:LA+L1) = ARG(J)(1:L1) LINA(LA+L1+1:LA+LA+2) = ', ' LA = LA + L1 + 2 100 CONTINUE C LINA(LA-1:LA-1) = ')' LA = LA - 1 CALL OUTLIN (1, LA, LINA) C C Release any temporaries among the arguments. C DO 110 I = 1, NAR LI = LAR(I) IF (LI .EQ. 4) THEN IF (ARG(I)(1:2) .EQ. 'MP') THEN TMP1 = ARG(I)(1:4) CALL RLTMP (TMP1) ENDIF ENDIF 110 CONTINUE C GOTO 130 C 120 CALL ERRMES (19, 0) WRITE (6, 2) NAMX 2 FORMAT ('Improper number of arguments for this special', $ ' subroutine: ',A) CALL ABRT C 130 RETURN END C SUBROUTINE CHKARG (LU, NAM, NAR, ITAR, LAR, ARG) C C This routine checks to see if a subroutine or function name is in the C subprogram table. If it is, the calling sequence is compared with that C in the table. If not, it is added to the table. LU is the unit number C for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG(MAR) CHARACTER*16 NAM, NAMX DIMENSION ITAR(MAR), LAR(MAR) C IX = ITAB (0, 0, NAM) IF (IX .EQ. 0) CALL ERRMES (20, 1) NAMX = VAR(IX) C C Check if the function name is in the subprogram table. C DO 100 I = 1, NSUB IF (SNAM(I) .EQ. NAMX) GOTO 120 100 CONTINUE C C Insert this function and its calling sequence in the subprogram table. C NSUB = NSUB + 1 IF (NSUB .GT. MSUB) THEN CALL ERRMES (21, 0) WRITE (6, 1) 1 FORMAT ('Too many program units in this file.') CALL ABRT ENDIF SNAM(NSUB) = NAMX NARS(NSUB) = NAR KSTP(0,NSUB) = KTYP(IX) C DO 110 I = 1, NAR KSTP(I,NSUB) = ITAR(I) 110 CONTINUE C GOTO 150 C C The function name is in the subprogram table. Check if the types of the C result and the arguments are the same as in the table. C 120 KS = I IF (NAR .NE. NARS(KS)) GOTO 140 IF (KTYP(IX) .NE. KSTP(0,KS)) GOTO 140 C DO 130 I = 1, NAR IF (ITAR(I) .NE. KSTP(I,KS)) GOTO 140 130 CONTINUE C GOTO 150 C C A warning message or a fatal error is generated, depending on the type C error flag ITE. C 140 IF (ITE .EQ. 0) THEN WRITE (LU, 2) NAM 2 FORMAT ('CMP*'/'CMP* The result type or argument list of this', $ ' function or subroutine is'/'CMP* incompatible with a', $ ' previous definition or reference: ',A/'CMP*') ELSE CALL ERRMES (22, 0) WRITE (6, 3) NAM 3 FORMAT ('The result type or argument list of this function or', $ ' subroutine is'/'incompatible with a previous definition or', $ ' reference: ',A) CALL ABRT ENDIF C 150 RETURN END C SUBROUTINE COPY C C This reads the generated code for one subprogram and copies it to the C output file, inserting MP declaration code at the marker if required. C CHARACTER*80 LIN C ENDFILE 11 REWIND 11 ENDFILE 12 REWIND 12 C 100 READ (11, '(A)', END = 110) LIN LN = LNBLK (LIN) IF (LN .EQ. 6 .AND. LIN(1:6) .EQ. 'CMP>>>') THEN CALL INIMP ELSE WRITE (6, '(A)') LIN(1:LN) ENDIF GOTO 100 C 110 REWIND 11 REWIND 12 RETURN END C SUBROUTINE DIMEN (K1, LN) C C This processes dimension and common statements by delimiting variable C names, inserting in table if required and correcting dimensions of MP C variables. K1 and LN are the indices of the first (after 'dimension' or C 'common') and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*16 NAM CHARACTER*1 CJ CHARACTER*8 DIM1, DIM2, DIMY C C Place the MP dimension into the character variable DIMX. C WRITE (DIMY, '(I8)') MXP + 4 I1 = NBLK (1, 8, DIMY) LD1 = 9 - I1 DIM1 = DIMY(I1:8) WRITE (DIMY, '(I8)') 2 * MXP + 8 I1 = NBLK (1, 8, DIMY) LD2 = 9 - I1 DIM2 = DIMY(I1:8) J1 = K1 C C Output statement as a comment. C CALL OUTLIN (2, LN, LINE) C C Extract the next character from the line. C 100 IF (J1 .GT. LN) GOTO 130 J1 = NBLK (J1, LN, LINE) CJ = LINE(J1:J1) C C Check if it the start of a name. C IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN C DO 110 J = J1, LN CJ = LINE(J:J) IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) GOTO 110 IF (INDEX (DIG, CJ) .NE. 0) GOTO 110 IF (INDEX (DEL, CJ) .NE. 0) GOTO 120 CALL ERRMES (23, 1) 110 CONTINUE C J = LN + 1 120 J2 = J - 1 NAM = LINE(J1:J2) IX = ITAB (1, 0, NAM) IF (IX .EQ. 0) THEN CALL ERRMES (24, 0) WRITE (6, 1) NAM 1 FORMAT ('This Fortran keyword may not appear in a dimension', $ ' or common statement: '/A) CALL ABRT ENDIF KTP = KTYP(IX) IF (KTP .LT. 8) KDEC(IX) = 1 IF (J2 .GE. LN) GOTO 130 K3 = NBLK (J2 + 1, LN, LINE) CJ = LINE(K3:K3) C C Check if this variable has a dimension declaration. C IF (CJ .EQ. '(') THEN KDIM(IX) = 1 C C If this is a MP variable, correct the dimension. C IF (KTP .GE. 8) THEN LINA(1:K3) = LINE(1:K3) IF (KTP .LT. 10) THEN LINA(K3+1:K3+LD1) = DIM1(1:LD1) LDX = LD1 ELSE LINA(K3+1:K3+LD2) = DIM2(1:LD2) LDX = LD2 ENDIF LINA(K3+LDX+1:K3+LDX+1) = ',' LINA(K3+LDX+2:LN+LDX+1) = LINE(K3+1:LN) LN = LN + LDX + 1 LINE(1:LN) = LINA(1:LN) ENDIF J2 = MATCH (0, K3 + 1, LN, LINE) IF (J2 .EQ. 0) CALL ERRMES (25, 1) I1 = ISCAN (K3, J2, LINE) IF (I1 .NE. 0) THEN CALL ERRMES (26, 0) WRITE (6, 2) NAM 2 FORMAT ('The MP dimension on this variable is not', $ ' allowed: ',A) CALL ABRT ENDIF ENDIF J1 = J2 + 1 GOTO 100 C C The only other character that should appear here is a comma. C ELSEIF (CJ .EQ. ',') THEN J1 = J1 + 1 GOTO 100 ELSE CALL ERRMES (27, 1) ENDIF C 130 CALL OUTLIN (1, LN, LINE) WRITE (11, 3) 3 FORMAT ('CMP<') C RETURN END C SUBROUTINE ERRMES (IA, IB) C C This outputs a syntax error message with the line number. If IB is C nonzero, ABRT is also called. IA is the message code, which currently C is in the range 1 - 96. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ IF (IB .EQ. 0) THEN WRITE (6, 1) LCT, IA 1 FORMAT ('*** Error in statement starting at line',I6,3X,'Code', $ I6) ELSE WRITE (6, 2) LCT, IA 2 FORMAT ('*** Syntax error in statement starting at line',I6, $ 3X,'Code',I6) CALL ABRT ENDIF C RETURN END C SUBROUTINE EXEC (K1, LN) C C This handles MP executable statements. K1 and LN are the indices of the C first and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*16 LINQ, UCASE C C Check if this is a call statement. C J1 = K1 LQ = MIN (J1 + 15, LN) LINQ = UCASE (LINE(J1:LQ)) IF (LINQ(1:5) .EQ. 'CALL ') THEN J1 = NBLK (J1 + 5, LN, LINE) I1 = INDX (J1, LN, '(', LINE) IF (I1 .NE. 0) THEN CALL CALLST (J1, LN) GOTO 110 ENDIF ENDIF C C Check if this is a read or write statement. C IRW = 0 IF (LINQ(1:4) .EQ. 'READ') THEN IRW = 1 K3 = J1 + 4 ELSEIF (LINQ(1:5) .EQ. 'WRITE') THEN IRW = 2 K3 = J1 + 5 ENDIF IF (IRW .NE. 0) THEN K3 = NBLK (K3, LN, LINE) IF (LINE(K3:K3) .NE. '(') GOTO 100 J1 = K3 J2 = MATCH (0, J1 + 1, LN, LINE) IF (J2 .EQ. 0) CALL ERRMES (28, 1) CALL RDWR (IRW, J1, J2, LN) GOTO 110 ENDIF C C Check if this is an assignment statement. C 100 CALL ASST (J1, LN) C 110 RETURN END C SUBROUTINE EXPRES (LU, LA, LINA, ITPX, LX, ARGX) C C This processes the arithmetic and/or logical expression in LINA, of length C = LA. The result, after evaluation, is placed in ARGX, with type = ITPX, C and length = LX. If the last result was =, then the ARGX is set to blanks, C and ITPX and LX are set to zero. LU is the unit number for output code. C> C Uncomment this line on Sun and IBM workstations. C C IMPLICIT AUTOMATIC (A-Z) C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA, LINB, LINC CHARACTER*80 AR(2), ARG(MAR), ARG1, ARGX, ARGY CHARACTER*16 NAM DIMENSION ITAR(MAR), LAR(MAR), ITA(2), LNA(2), ID1(2), ID2(2), $ IOP(2) CHARACTER*1 CJ C* C write (lu, *) 'enter expres' C* C Search for an executable operation (one that is not dependent on the C results of operations with higher precedence) in the statement. The two C arguments of the operation, their types and lengths, are identified. C LB = LA LINB(1:LB) = LINA(1:LA) C 100 I1 = 1 C* C write (lu, *) 'expres lb =', lb C write (lu, *) '%'//linb(1:lb)//'%' C* 110 DO 200 II = 1, 2 IF (I1 .GT. LB) CALL ERRMES (29, 1) I1 = NBLK (I1, LB, LINB) CJ = LINB(I1:I1) IX = 0 C* C write (lu, *) 'cj =', cj C* C Check if this is the start of a numeric constant. C IS1 = INDEX (DIG, CJ) IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. I1 .LT. LB) THEN I2 = NBLK (I1 + 1, LB, LINB) IS2 = INDEX (DIG, LINB(I2:I2)) ELSE IS2 = 0 ENDIF C IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN IT = NUMCON (I1, I2, LB, LINB) C C If the mixed mode safe flag is on, then the numeric constant is always C of type MP. C IF (IMM .GE. 1) THEN IF (IT .EQ. 1) THEN IT = 8 ELSEIF (IT .EQ. 2 .or. IT .EQ. 3) THEN IT = 9 ENDIF ENDIF IF (IT .LE. 3) THEN ID1(II) = I1 ID2(II) = I2 ITA(II) = IT LNA(II) = I2 - I1 + 1 AR(II) = LINB(I1:I2) ELSE ID1(1) = I1 ID2(2) = I2 ITPY = IT CALL GENCON (LU, I1, I2, LINB, ITPY, LY, ARGY) I1 = NBLK (I2 + 1, LB, LINB) GOTO 220 ENDIF C C Check if string is a variable name. C ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN C DO 120 J = I1, LB CJ = LINB(J:J) IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN GOTO 120 ELSEIF (INDEX (DIG, CJ) .NE. 0) THEN GOTO 120 ELSE GOTO 130 ENDIF 120 CONTINUE C J = LB + 1 C C Variable or function name has been identified. C 130 I2 = J - 1 L1 = I2 - I1 + 1 NAM = LINB(I1:I2) IX = ITAB (1, 0, NAM) IF (IX .EQ. 0) THEN CALL ERRMES (30, 0) WRITE (6, 1) NAM 1 FORMAT ('This Fortran keyword may not appear in an', $ ' expression: ',A) CALL ABRT ELSEIF (KTYP(IX) .EQ. 0) THEN CALL ERRMES (31, 0) WRITE (6, 2) NAM 2 FORMAT ('This variable has not been typed: ',A) CALL ABRT ENDIF ID1(II) = I1 ID2(II) = I2 ITA(II) = KTYP(IX) LNA(II) = L1 AR(II)(1:L1) = LINB(I1:I2) C C Check if string is a logical constant. C ELSEIF (CJ .EQ. '.' .AND. I1 .LT. LB .AND. $ (LINB(I1+1:I1+1) .EQ. 'T' .OR. LINB(I1+1:I1+1) .EQ. 't' .OR. $ LINB(I1+1:I1+1) .EQ. 'F' .OR. LINB(I1+1:I1+1) .EQ. 'f')) $ THEN IF (LINB(I1:I1+2) .EQ. '.T.' .OR. LINB(I1:I1+2) .EQ. '.t.'.OR. $ LINB(I1:I1+2) .EQ. '.F.' .OR. LINB(I1:I1+2) .EQ. '.t.') $ THEN I2 = I1 + 2 ELSEIF (LINB(I1:I1+5) .EQ. '.TRUE.' .OR. $ LINB(I1:I1+5) .EQ. '.true.') THEN I2 = I1 + 5 ELSEIF (LINB(I1:I1+6) .EQ. '.FALSE.' .OR. $ LINB(I1:I1+6) .EQ. '.false.') THEN I2 = I1 + 6 ELSE CALL ERRMES (32, 1) ENDIF ID1(II) = I1 ID2(II) = I2 ITA(II) = 7 LNA(II) = I2 - I1 + 1 AR(II) = LINB(I1:I2) C C Check if argument is a character constant delimited by ". C ELSEIF (CJ .EQ. '"') THEN J1 = I1 140 I2 = INDX (J1 + 1, LB, '"', LINB) IF (I2 .EQ. 0) CALL ERRMES (33, 1) IF (I2 .LT. LB .AND. LINB(I2+1:I2+1) .EQ. '"') THEN J1 = I2 + 1 GOTO 140 ENDIF ID1(II) = I1 ID2(II) = I2 ITA(II) = 6 LNA(II) = I2 - I1 + 1 AR(II) = LINB(I1:I2) C C Check if argument is a character constant delimited by '. C ELSEIF (CJ .EQ. "'") THEN J1 = I1 150 I2 = INDX (J1 + 1, LB, "'", LINB) IF (I2 .EQ. 0) CALL ERRMES (34, 1) IF (I2 .LT. LB .AND. LINB(I2+1:I2+1) .EQ. "'") THEN J1 = I2 + 1 GOTO 150 ENDIF ID1(II) = I1 ID2(II) = I2 ITA(II) = 6 LNA(II) = I2 - I1 + 1 AR(II) = LINB(I1:I2) C C Check if argument is a unary minus sign (i.e. argument 1 is null). C ELSEIF (CJ .EQ. '-') THEN IF (II .EQ. 2) GOTO 110 ID1(1) = I1 ID2(1) = I1 ITA(1) = 0 LNA(1) = 1 AR(1) = ' ' IOP(1) = 3 I1 = I1 + 1 GOTO 200 C C Check if the next character is a left parenthesis. If so, evaluate the C expression in parentheses. C ELSEIF (CJ .EQ. '(') THEN I2 = MATCH (0, I1 + 1, LB, LINB) IF (I2 .EQ. 0) CALL ERRMES (35, 1) LC = I2 - I1 - 1 LINC(1:LC) = LINB(I1+1:I2-1) ID1(1) = I1 ID2(2) = I2 IF (LB .EQ. 0) CALL ERRMES (36, 1) CALL EXPRES (LU, LC, LINC, ITPY, LY, ARGY) GOTO 220 ELSE CALL ERRMES (37, 0) WRITE (6, 3) CJ 3 FORMAT ('Illegal character: ',A) CALL ABRT ENDIF C C Check if the end of the variable or constant is the end of the statement. C 160 CONTINUE IF (I2 .EQ. LB .OR. LINB(I2+1:LB) .EQ. ' ') THEN C C If this occurs on the first pass, we are done. C IF (II .EQ. 1) THEN ITPX = ITA(1) LX = LNA(1) ARGX(1:LX) = AR(1)(1:LX) GOTO 230 C C If this occurs on the second pass, proceed to evaluate. C ELSE GOTO 210 ENDIF ENDIF C C Check if the next character after the variable name is a left parenthesis. C I3 = NBLK (I2 + 1, LB, LINB) CJ = LINB(I3:I3) IF (CJ .EQ. '(') THEN IF (IX .EQ. 0) CALL ERRMES (38, 1) I2 = MATCH (0, I3 + 1, LB, LINB) IF (I2 .EQ. 0) CALL ERRMES (39, 1) K1 = INDEX (LINB(I2:LB), '=') 170 CONTINUE C C Check if the subscripted variable is really a function reference. C IF (KDIM(IX) .EQ. -1) THEN IF (K1 .NE. 0) THEN CALL ERRMES (40, 0) WRITE (6, 4) NAM(1:L1) 4 FORMAT ('A function name may not appear on the LHS of', $ ' an assignment statement: ',A) CALL ABRT ENDIF C C Generate a function call. If it is an intrinsic reference and the mixed C mode SAFE option is in effect, set IMM = 2 as a flag to inform ARLIST not C to revert to mixed mode FAST while evaluating the argument list. C ID1(1) = I1 ID2(2) = I2 LC = I2 - I3 - 1 LINC(1:LC) = LINB(I3+1:I2-1) IMS = IMM IF (IX .LE. MINT .AND. IMM .GE. 1) IMM = 2 CALL ARLIST (LU, LC, LINC, NAR, ITAR, LAR, ARG) IMM = IMS IT1 = ITA(II) LN1 = LNA(II) ARG1 = AR(II) CALL GENFUN (LU, IT1, LN1, ARG1, NAR, ITAR, LAR, ARG, ITPY, $ LY, ARGY) I1 = NBLK (I2 + 1, LB, LINB) GOTO 220 C C Check if the subscripted variable has a dimension. C ELSEIF (KDIM(IX) .EQ. 0) THEN IF (K1 .EQ. 0) THEN KT = KTYP(IX) WRITE (LU, 5) NAM(1:L1), CTP(KT) 5 FORMAT ('CMP*'/'CMP* Undimensioned variable assumed to', $ ' be an external function.'/'CMP* Name: ',A,4X, $ 'Type: ',A/'CMP*') KDIM(IX) = -1 KDEC(IX) = 1 GOTO 170 ELSE CALL ERRMES (41, 0) WRITE (6, 6) 6 FORMAT ('MP variables may not be used in statement', $ ' function definitions.'/'Define an external function', $ ' for this purpose.') CALL ABRT ENDIF C C Otherwise it must be an ordinary array with subscript. The combination of C the variable name and the subscript will now be treated as a variable. C IX is set to 0 as a flag indicating that this has been done. C ELSE I4 = ISCAN (I3, I2, LINB) IF (I4 .NE. 0) THEN CALL ERRMES (42, 0) WRITE (6, 7) NAM 7 FORMAT ('The MP subscript on this variable is not', $ ' allowed: ',A) CALL ABRT ENDIF L1 = I2 - I1 + 1 ID2(II) = I2 LNA(II) = L1 AR(II)(1:L1) = LINB(I1:I2) IX = 0 GOTO 160 ENDIF ELSE C C The variable does not have a subscript. Check if it has a dimension. C IF (IX .GT. 0) THEN IF (KDIM(IX) .GT. 0) THEN CALL ERRMES (43, 0) WRITE (6, 8) NAM(1:L1) 8 FORMAT ('This dimensioned variable is used without a', $ ' subscript: ',A) CALL ABRT ENDIF ENDIF ENDIF I1 = I3 C C Identify the operator. C DO 180 I = 1, NOP L1 = LOP(I) - 1 IF (LINB(I1:I1+L1) .EQ. LOPR(I) .OR. LINB(I1:I1+L1) .EQ. $ UOPR(I)) GOTO 190 180 CONTINUE C CALL ERRMES (44, 0) WRITE (6, 9) LINB(I1:I1) 9 FORMAT ('Illegal operator: ',A) CALL ABRT C 190 IOP(II) = I I1 = I1 + LOP(I) 200 CONTINUE C C Compare the precedence levels of the two operators. C IF (KOP(IOP(1)) .LT. KOP(IOP(2))) THEN I1 = ID1(2) GOTO 110 ENDIF C C An operation can be performed. C 210 CALL GEN (LU, ITA, LNA, AR, IOP(1), ITPY, LY, ARGY) C C Replace the two operands and the operator with the result in LINB. C 220 IF (LY .NE. 0) THEN I1 = ID1(1) I2 = ID2(2) L1 = I2 - I1 + 1 LD = LY - L1 IF (I1 .GT. 0) LINC(1:I1-1) = LINB(1:I1-1) LINC(I1:I1+LY-1) = ARGY(1:LY) IF (LB .GT. I2) LINC(I1+LY:LB+LD) = LINB(I2+1:LB) LB = LB + LD LINB(1:LB) = LINC(1:LB) GOTO 100 ELSE ITPX = ITPY LX = LY ARGX = ARGY ENDIF C C Finished at last. C 230 CONTINUE C* C write (lu, *) 'exit express, argx = %'//argx(1:lx)//'%' C* RETURN END C SUBROUTINE FIXSUB (K1, K2, LN) C C This routine prepends '1,' to subscripts MP variables in LINE between K1 C and K2. LN is the length of the full line. It also changes the names of C the special constants when found. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINX CHARACTER*16 NAM, NAMQ CHARACTER*1 CJ C J1 = K1 NAMQ = 'MPNWP' IQNWP = ITAB (0, 0, NAMQ) NAMQ = 'DPPIC' IQPIC = ITAB (0, 0, NAMQ) IQD = IQPIC - IQNWP + 1 C C Extract the next character from the line. C 100 IF (J1 .GT. K2) GOTO 130 J1 = NBLK (J1, K2, LINE) CJ = LINE(J1:J1) C C Check if it is the start of a numeric constant. C IS1 = INDEX (DIG, CJ) IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. J1 .LT. K2) THEN J2 = NBLK (J1 + 1, K2, LINE) IS2 = INDEX (DIG, LINE(J2:J2)) ELSE IS2 = 0 ENDIF C IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN ITP = NUMCON (J1, J2, LN, LINE) J1 = J2 + 1 GOTO 100 C C Check if it the start of a name. C ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN C DO 110 J = J1, K2 CJ = LINE(J:J) IF (INDEX (DEL, CJ) .NE. 0) GOTO 120 110 CONTINUE C J = K2 + 1 C C The variable has been identified. C 120 I2 = J - 1 NAM = LINE(J1:I2) IX = ITAB (0, 0, NAM) IF (IX .EQ. 0) THEN J1 = I2 + 1 GOTO 100 ENDIF ITP = KTYP(IX) C C Check if the variable is the function value. If so, change its name. C IF (KDIM(IX) .EQ. -2) THEN LX = LN - I2 + 5 LINX(1:5) = 'MPFVX' LINX(6:LX) = LINE(I2+1:LN) LD = J1 - I2 + 4 K2 = K2 + LD LN = LN + LD LINE(J1:LN) = LINX(1:LX) J1 = J1 + 5 GOTO 100 C C Check if the variable is a special constant. If so, change its name. C ELSEIF (IX .GE. IQNWP .AND. IX .LE. IQPIC) THEN LINE(J1:I2) = VAR(IX+IQD) KCON(IX) = 1 J1 = I2 + 1 GOTO 100 C C Check if the variable is MP. C ELSEIF (ITP .GE. 8) THEN C C Check if this MP variable has a subscript. C I1 = NBLK (I2 + 1, K2, LINE) IF (I1 .EQ. 0) GOTO 130 IF (LINE(I1:I1) .EQ. '(') THEN IF (KDIM(IX) .GT. 0) THEN LX = LN - I1 + 2 LINX(1:2) = '1,' LINX(3:LX) = LINE(I1+1:LN) LINE(I1+1:LN+2) = LINX(1:LX) K2 = K2 + 2 LN = LN + 2 J1 = INDX (I1 + 1, K2, ')', LINE) IF (J1 .EQ. 0) CALL ERRMES (45, 1) ENDIF ELSE J1 = I2 + 1 GOTO 100 ENDIF ENDIF J1 = I2 + 1 GOTO 100 C C Check if it is the start of a logical constant. C ELSEIF (CJ .EQ. '.') THEN I1 = INDX (J1 + 1, K2, '.', LINE) IF (I1 .EQ. 0) CALL ERRMES (46, 1) J1 = I1 + 1 GOTO 100 C C Check if it is the start of a character constant. C ELSEIF (CJ .EQ. '"') THEN I1 = INDX (J1 + 1, K2, '"', LINE) IF (I1 .EQ. 0) CALL ERRMES (47, 1) J1 = I1 + 1 GOTO 100 ELSEIF (CJ .EQ. "'") THEN I1 = INDX (J1 + 1, K2, "'", LINE) IF (I1 .EQ. 0) CALL ERRMES (48, 1) J1 = I1 + 1 GOTO 100 ENDIF C C Check if it is one of the miscellaneous symbols. C I1 = INDEX (DEL, CJ) IF (I1 .EQ. 0) CALL ERRMES (49, 1) J1 = J1 + 1 GOTO 100 C 130 RETURN END C SUBROUTINE GEN (LU, ITA, LNA, AR, IOP, ITPX, LX, ARGX) C C This generates code for a single operation. The two input argument names C are in AR, with types in ITA and lengths in LNA. The operation code is in C IOP. The result (ordinarily a temporary variable name, but empty in case C of assignments) is placed in ARGX, with type ITPX and length LX. LU is C the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*80 AR(2), ARG1, ARG2, ARG3, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP DIMENSION ITA(2), LNA(2) C ITP1 = ITA(1) L1 = LNA(1) ARG1(1:L1) = AR(1)(1:L1) ITP2 = ITA(2) L2 = LNA(2) ARG2(1:L2) = AR(2)(1:L2) C* C write (lu, *) 'enter gen ', itp1, itp2, ' ', uopr(iop) C write (lu, *) 'args: ', arg1(1:l1), ' ', arg2(1:l2) C* C Check for character entities with non-character entities. C IF (ITP1 .EQ. 6 .AND. ITP2 .NE. 6 .OR. ITP1 .NE. 6 .AND. $ ITP2 .EQ. 6) GOTO 110 C C Check for logical entities with non-logical entities. C IF (ITP1 .EQ. 7 .AND. ITP2 .NE. 7 .OR. ITP1 .NE. 7 .AND. $ ITP2 .EQ. 7) GOTO 110 C C Check for assignments. C IF (IOP .EQ. 1) THEN ITPX = 0 ARGX(1:4) = ' ' LX = 0 CALL GENASN (LU, ITP1, L1, ARG1, ITP2, L2, ARG2) GOTO 100 ENDIF C C Handle all other operations here. The result variable will be a C temporary variable and the result type is the max of the two type numbers, C except for comparisons and a couple of other mixed mode cases. C IF (IOP .LE. 6) THEN IF (ITP1 .EQ. 8 .AND. (ITP2 .EQ. 2 .OR. ITP2 .EQ. 3) .OR. $ ITP2 .EQ. 8 .AND. (ITP1 .EQ. 2 .OR. ITP1 .EQ. 3)) THEN ITPX = 9 ELSEIF (ITP1 .GE. 8 .AND. (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) .OR. $ ITP2 .GE. 8 .AND. (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5)) THEN ITPX = 10 ELSE ITPX = MAX (ITP1, ITP2) ENDIF C C If the mixed mode safe option is in effect, change IN, SP, DP, CO and DC C results to the appropriate MP type. C IF (IMM .GE. 1) THEN IF (ITPX .EQ. 1) THEN ITPX = 8 ITP3 = 8 ELSEIF (ITPX .EQ. 2 .OR. ITPX .EQ. 3) THEN ITPX = 9 ITP3 = 9 ELSEIF (ITPX .EQ. 4 .OR. ITPX .EQ. 5) THEN ITPX = 10 ITP3 = 10 ENDIF ENDIF ELSE ITPX = 7 ENDIF C C Check if the operation is really the definition of a MPI or MPR constant. C IF (IOP .EQ. 2 .AND. L2 .EQ. 1 .AND. ARG2(1:1) .EQ. '0') THEN IF (INDEX (DIG, ARG1(1:1)) .NE. 0 .OR. ARG1(1:1) .EQ. '.' .OR. $ ARG1(1:1) .EQ. '-' .OR. ARG1(1:1) .EQ. '+') THEN LINA(1:L1) = ARG1(1:L1) IF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 8) THEN ITPX = 8 ELSEIF (ITP1 .EQ. 2 .OR. ITP1 .EQ. 3 .OR. ITP1 .EQ. 9) THEN ITPX = 9 ENDIF CALL GENCON (LU, 1, L1, LINA, ITPX, LX, ARGX) ELSE ITPX = ITP1 LX = L1 ARGX(1:LX) = ARG1(1:L1) ENDIF GOTO 120 ENDIF LX = 4 ARGX(1:4) = GETMP (ITPX) C C Generate code for non-MP operands. C IF (ITP1 .LT. 8 .AND. ITP2 .LT. 8) THEN IF (IMM .EQ. 0 .OR. ITP1 .EQ. 7 .AND. ITP2 .EQ. 7 .OR. $ IOP .GE. 7) THEN C C Either mixed mode fast option is in effect, or else the operation is a C comparison or logical operation. Generate a simple one line non-MP C statement. C WRITE (LU, 1) ARGX(1:4), ARG1(1:L1), UOPR(IOP)(1:LOP(IOP)), $ ARG2(1:L2) 1 FORMAT (6X,A,' = ',A,' ',A,' ',A) GOTO 100 ELSE C C The mixed mode safe option is in effect. Convert the left operand to C the appropriate MP type so that it will be evaluated using the MP routines. C TMP1 = GETMP (ITP3) ARG3(1:4) = TMP1 L3 = 4 CALL GENASN (LU, ITP3, L3, ARG3, ITP1, L1, ARG1) C C If ARG1 is a temporary, release it. Then set ARG1 = ARG3 and generate C code for this operation using the appropriate GENXXX routine. C IF (L1 .EQ. 4) THEN IF (ARG1(1:2) .EQ. 'MP') THEN TMP1 = ARG1(1:4) CALL RLTMP (TMP1) ENDIF ENDIF ITP1 = ITP3 L1 = L3 ARG1(1:L1) = ARG3(1:L3) ENDIF ENDIF C C Check if operation is a plus. C IF (IOP .EQ. 2) THEN CALL GENADD (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C Check if the operation is minus. C ELSEIF (IOP .EQ. 3) THEN CALL GENSUB (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C Check if the operation is exponentiation. C ELSEIF (IOP .EQ. 4) THEN CALL GENEXP (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C Check if the operation is multiplication. C ELSEIF (IOP .EQ. 5) THEN CALL GENMUL (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C Check if the operation is division. C ELSEIF (IOP .EQ. 6) THEN CALL GENDIV (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C Check if the operation is comparison. C ELSEIF (IOP .GE. 7 .AND. IOP .LE. 12) THEN CALL GENCPR (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, IOP, ARGX) GOTO 100 ELSE GOTO 110 ENDIF C C If the result is of type MPI, truncate the result. C IF (ITPX .EQ. 8) THEN TMP1 = GETMP (9) WRITE (LU, 2) ARGX(1:4), ARGX(1:4), TMP1 2 FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) ENDIF C C Release any temporaries among the arguments. C 100 IF (L1 .EQ. 4) THEN IF (ARG1(1:2) .EQ. 'MP') THEN TMP1 = ARG1(1:4) CALL RLTMP (TMP1) ENDIF ENDIF IF (L2 .EQ. 4) THEN IF (ARG2(1:2) .EQ. 'MP') THEN TMP1 = ARG2(1:4) CALL RLTMP (TMP1) ENDIF ENDIF GOTO 120 C 110 CALL ERRMES (50, 0) WRITE (6, 3) UOPR(IOP)(1:LOP(IOP)) 3 FORMAT ('Operation ',A,' is not defined with these operands.') CALL ABRT C 120 CONTINUE C* C write (lu, *) 'exit gen itpx, lx, argx =', itpx, lx, ' ', C $ argx(1:lx) C* RETURN END C SUBROUTINE GENADD (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C This generates code for an add operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C IF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3) THEN C C (Arg1 is DP) and (Arg2 is MP). C TMP1 = GETMP (9) IF (ITP2 .EQ. 10) THEN WRITE (LU, 1) ARG2(1:L2), ARGX(1:4) 1 FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')') ENDIF WRITE (LU, 2) ARG1(1:L1), TMP1 2 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 3) TMP1, ARG2(1:L2), ARGX(1:4) 3 FORMAT (6X,'CALL MPADD (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN C C (Arg1 is IN or SP) and (Arg2 is MP). C TMP1 = GETMP (3) TMP2 = GETMP (9) IF (ITP2 .EQ. 10) THEN WRITE (LU, 1) ARG2(1:L2), ARGX(1:4) ENDIF WRITE (LU, 4) TMP1, ARG1(1:L1) 4 FORMAT (6X,A,' = ',A) WRITE (LU, 2) TMP1, TMP2 WRITE (LU, 3) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is CO or DC) and (Arg2 is MP). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP1 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG1(1:L1) 5 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 6) TMP2, ARG1(1:L1) 6 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 7) TMP1, ARG1(1:L1) 7 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 8) TMP2, ARG1(1:L1) 8 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 2) TMP1, TMP3 WRITE (LU, 2) TMP2, TMP4 WRITE (LU, 9) TMP3, TMP4, TMP5 9 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') IF (ITP2 .EQ. 10) THEN WRITE (LU, 10) TMP5, ARG2(1:L2), ARGX(1:4) 10 FORMAT (6X,'CALL MPCADD (MPNW4, ',A,', ',A,', ',A,')') ELSE TMP6 = GETMP (10) WRITE (LU, 11) TMP3 11 FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')') WRITE (LU, 9) ARG2(1:L2), TMP3, TMP6 WRITE (LU, 10) TMP5, TMP6, ARGX(1:4) CALL RLTMP (TMP6) ENDIF CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN C C (Arg1 is MP) and (Arg2 is DP). C TMP1 = GETMP (9) IF (ITP1 .EQ. 10) THEN WRITE (LU, 1) ARG1(1:L1), ARGX(1:4) ENDIF WRITE (LU, 2) ARG2(1:L2), TMP1 WRITE (LU, 3) ARG1(1:L1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN C C (Arg1 is MP) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) IF (ITP1 .EQ. 10) THEN WRITE (LU, 1) ARG1(1:L1), ARGX(1:4) ENDIF WRITE (LU, 4) TMP1, ARG2(1:L2) WRITE (LU, 2) TMP1, TMP2 WRITE (LU, 3) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MP) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP2 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG2(1:L2) WRITE (LU, 6) TMP2, ARG2(1:L2) ELSE WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 2) TMP1, TMP3 WRITE (LU, 2) TMP2, TMP4 WRITE (LU, 9) TMP3, TMP4, TMP5 IF (ITP1 .EQ. 10) THEN WRITE (LU, 10) ARG1(1:L1), TMP5, ARGX(1:4) ELSE TMP6 = GETMP (10) WRITE (LU, 11) TMP3 WRITE (LU, 9) ARG1(1:L1), TMP3, TMP6 WRITE (LU, 10) TMP6, TMP5, ARGX(1:4) CALL RLTMP (TMP6) ENDIF CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C WRITE (LU, 3) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (10) WRITE (LU, 11) TMP1 WRITE (LU, 9) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 10) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPC) and (Arg1 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (10) WRITE (LU, 11) TMP1 WRITE (LU, 9) ARG2(1:L2), TMP1, TMP2 WRITE (LU, 10) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MPC) and (Arg2 is MPC). C WRITE (LU, 10) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ENDIF C RETURN END C SUBROUTINE GENASN (LU, ITP1, L1, ARG1, ITP2, L2, ARG2) C C This generates code for an assign operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. There is no C "result" temporary with assignments. LU is the unit number for output C code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*16 NAM, NAMQ CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C NAMQ = 'MPNWP' IQNWP = ITAB (0, 0, NAMQ) NAMQ = 'DPPIC' IQPIC = ITAB (0, 0, NAMQ) IQD = IQPIC - IQNWP + 1 ISC = IQNWP + 2 * IQD - 1 C C Check if Arg1 is an appropriate name for the result of an assignment C (i.e. it must not be special constant or a function name or parameter). C K = INDEX (ARG1, '(') IF (K .EQ. 0) K = 100 L = MIN (K - 1, L1, 16) NAM = ARG1(1:L) IX = ITAB (0, 0, NAM) IF (IX .GT. IQPIC .AND. IX .LE. ISC .AND. LU .EQ. 12) THEN IX = IX - IQD WRITE (LU, 1) VAR(IX)(1:LVAR(IX)) 1 FORMAT ('CMP*'/'CMP* The parameter definition of this special', $ ' constant is ignored: ',A/'CMP*') GOTO 100 ELSEIF (IX .LE. MINT .OR. KDIM(IX) .LT. 0) THEN CALL ERRMES (51, 0) WRITE (6, 2) NAM(1:L) 2 FORMAT ('This name may not appear on the LHS of an assignment', $ ' statement: ',A) CALL ABRT ELSEIF (LU .EQ. 12) THEN C C If this is a MP parameter definition, set KDIM(IX) to -3 so that it can't C be stored into again. C KDIM(IX) = -3 ENDIF C IF (ITP1 .LT. 8) THEN IF (ITP2 .LT. 8) THEN C C (LHS is non-MP) and (RHS is non-MP). C WRITE (LU, 3) ARG1(1:L1), ARG2(1:L2) 3 FORMAT (6X,A,' = ',A) ELSEIF (ITP1 .LE. 3 .OR. ITP2 .NE. 10) THEN C C (LHS is IN, SP or DP) or (RHS is MPI or MPR). At least one is not complex. C TMP1 = GETMP (3) TMP2 = GETMP (1) WRITE (LU, 4) ARG2(1:L2), TMP1, TMP2 4 FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')') WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2 5 FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (LHS is CO or DC) and (RHS is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (3) TMP4 = GETMP (3) TMP5 = GETMP (1) WRITE (LU, 6) ARG2(1:L2), TMP1, TMP2 6 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (LU, 4) TMP1, TMP3, TMP5 WRITE (LU, 5) TMP3, TMP3, TMP5 WRITE (LU, 4) TMP2, TMP4, TMP5 WRITE (LU, 5) TMP4, TMP4, TMP5 WRITE (LU, 7) ARG1(1:L1), TMP3, TMP4 7 FORMAT (6X,A,' = DCMPLX (',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN C C (LHS is MP) and (RHS is DP). C WRITE (LU, 8) ARG2(1:L2), ARG1(1:L1) 8 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') ELSEIF (ITP1 .NE. 10 .OR. ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN C C (LHS is MP) or (RHS is IN or SP). At least one is not complex. C TMP1 = GETMP (3) WRITE (LU, 3) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP1, ARG1(1:L1) CALL RLTMP (TMP1) ELSE C C (LHS is MPC) and (RHS is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) IF (ITP2 .EQ. 5) THEN WRITE (LU, 9) TMP1, ARG2(1:L2) 9 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 10) TMP2, ARG2(1:L2) 10 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 11) TMP1, ARG2(1:L2) 11 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 12) TMP2, ARG2(1:L2) 12 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 8) TMP1, TMP3 WRITE (LU, 8) TMP2, TMP4 WRITE (LU, 13) TMP3, TMP4, ARG1(1:L1) 13 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ENDIF ELSEIF (ITP1 .NE. 10 .OR. ITP2 .NE. 10) THEN C C (LHS is MPI or MPR) or (RHS is MPI or MPR). At least one is not MPC. C WRITE (LU, 14) ARG2(1:L2), ARG1(1:L1) 14 FORMAT (6X,'CALL MPEQ (',A,', ',A,')') ELSE C C (LHS is MPC) and (RHS is MPC). C WRITE (LU, 15) ARG2(1:L2), ARG1(1:L1) 15 FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')') ENDIF IF (ITP1 .EQ. 8 .AND. ITP2 .NE. 1 .AND. ITP2 .NE. 8) THEN C C Truncate the result if (LHS is MPI) and (RHS is not IN or MPI). C TMP1 = GETMP (9) WRITE (LU, 16) ARG1(1:L1), ARG1(1:L1), TMP1 16 FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 4 .AND. ITP2 .NE. 5 .AND. $ ITP2 .NE. 10) THEN C C Zero the imaginary part if (LHS is MPC) and (RHS is not CO or DC or MPC). C TMP1 = GETMP (9) WRITE (LU, 17) TMP1 17 FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')') WRITE (LU, 13) ARG1(1:L1), TMP1, ARG1(1:L1) CALL RLTMP (TMP1) ENDIF C 100 RETURN END C SUBROUTINE GENCON (LU, I1, I2, LINA, ITPY, LY, ARGY) C C This generates the code for a MPR constant. I1 and I2 are the indicies C of LINA delimiting the constant. The output MP temporary is placed in C ARGY, with length LY. LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA, LINB CHARACTER*80 ARGY CHARACTER*4 NUM, TMP1, TMP2, TMP3, GETMP C TMP1 = GETMP (11) TMP2 = GETMP (6) TMP3 = GETMP (1) LY = 4 ARGY(1:4) = GETMP (ITPY) LA = I2 - I1 + 1 L2 = MAX (INDEX (LINA(I1:I2), 'D'), INDEX (LINA(I1:I2), 'd'), $ INDEX (LINA(I1:I2), 'E'), INDEX (LINA(I1:I2), 'e')) - 1 IF (L2 .GE. 0) THEN L1 = LA - L2 - 1 ELSE L1 = 0 L2 = LA ENDIF LINB(1:6) = ' ' LINB(7:10) = TMP1 LINB(11:17) = " = '10^" IF (L1 .GT. 0) THEN LINB(18:L1+17) = LINA(I1+L2+1:I2) ELSE L1 = 1 LINB(18:18) = '0' ENDIF LINB(L1+18:L1+20) = ' x ' LINB(L1+21:L1+L2+20) = LINA(I1:I1+L2-1) LINB(L1+L2+21:L1+L2+21) = "'" L = L1 + L2 + 21 IF (LU .EQ. 11) THEN CALL OUTLIN (1, L, LINB) ELSE CALL OUTLIN (3, L, LINB) ENDIF LS = L1 + L2 + 6 LSM = MAX (LSM, LS) WRITE (NUM, '(I3)') LS WRITE (LU, 1) TMP1, NUM(1:3), TMP2, TMP3, TMP3, NUM(1:3) 1 FORMAT (6X,'READ (',A,", '(",A,"A1)' ) (",A,'(',A,'), ',A, $ ' = 1, ',A,')') WRITE (LU, 2) TMP2, LS, ARGY(1:4) 2 FORMAT (6X,'CALL MPINPC (',A,', ',I3,', ',A,')') CALL RLTMP (TMP3) C RETURN END C SUBROUTINE GENCPR (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, IOP, ARGX) C C This generates code for a compare operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*8 ANDOR CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C C If one of the operands has a complex type, only .EQ. and .NE. are allowed. C IF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5 .OR. ITP1 .EQ. 10 .OR. $ ITP2 .EQ. 4 .OR. ITP2 .EQ. 5 .OR. ITP2 .EQ. 10) THEN IF (IOP .GE. 9) GOTO 100 IF (IOP .EQ. 7) THEN ANDOR = '.AND.' ELSE ANDOR = '.OR.' ENDIF ENDIF C IF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is DP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (9) TMP2 = GETMP (1) WRITE (LU, 1) ARG1(1:L1), TMP1 1 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 2) TMP1, ARG2(1:L2), TMP2 2 FORMAT (6X,'CALL MPCPR (',A,', ',A,', ',A,')') WRITE (LU, 3) ARGX(1:4), TMP2, UOPR(IOP)(1:LOP(IOP)) 3 FORMAT (6X,A,' = ',A,' ',A,' 0') CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is DP) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (1) TMP6 = GETMP (1) WRITE (LU, 1) ARG1(1:L1), TMP1 WRITE (LU, 4) TMP2 4 FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')') WRITE (LU, 5) ARG2(1:L2), TMP3, TMP4 5 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (LU, 2) TMP1, TMP3, TMP5 WRITE (LU, 2) TMP2, TMP4, TMP6 WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP)) 6 FORMAT (6X,A,' = ',A,' ',A,' 0 ',A,' ',A,' ',A,' 0') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ENDIF ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is IN or SP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (1) WRITE (LU, 7) TMP1, ARG1(1:L1) 7 FORMAT (6X,A,' = ',A) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 2) TMP2, ARG2(1:L2), TMP3 WRITE (LU, 3) ARGX(1:4), TMP3, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ELSE C C (Arg1 is IN or SP) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (9) TMP6 = GETMP (1) TMP7 = GETMP (1) WRITE (LU, 7) TMP1, ARG1(1:L1) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 4) TMP3 WRITE (LU, 5) ARG2(1:L2), TMP4, TMP5 WRITE (LU, 2) TMP2, TMP4, TMP6 WRITE (LU, 2) TMP3, TMP5, TMP7 WRITE (LU, 6) ARGX(1:4), TMP6, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP7, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) CALL RLTMP (TMP7) ENDIF ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is CO or DC) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (1) IF (ITP1 .EQ. 5) THEN WRITE (LU, 8) TMP1, ARG1(1:L1) 8 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 9) TMP2, ARG1(1:L1) 9 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 10) TMP1, ARG1(1:L1) 10 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 11) TMP2, ARG1(1:L1) 11 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 2) TMP3, ARG2(1:L2), TMP4 WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP2, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ELSE C C (Arg1 is CO or DC) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (9) TMP6 = GETMP (9) TMP7 = GETMP (1) TMP8 = GETMP (1) IF (ITP1 .EQ. 5) THEN WRITE (LU, 8) TMP1, ARG1(1:L1) WRITE (LU, 9) TMP2, ARG1(1:L1) ELSE WRITE (LU, 10) TMP1, ARG1(1:L1) WRITE (LU, 11) TMP2, ARG1(1:L1) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 5) ARG2(1:L2), TMP5, TMP6 WRITE (LU, 2) TMP3, TMP5, TMP7 WRITE (LU, 2) TMP4, TMP6, TMP8 WRITE (LU, 6) ARGX(1:4), TMP7, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP8, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) CALL RLTMP (TMP7) CALL RLTMP (TMP8) ENDIF ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is DP). C TMP1 = GETMP (9) TMP2 = GETMP (1) WRITE (LU, 1) ARG2(1:L2), TMP1 WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 3) ARGX(1:4), TMP2, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MPC) and (Arg2 is DP). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (1) TMP6 = GETMP (1) WRITE (LU, 1) ARG2(1:L2), TMP1 WRITE (LU, 4) TMP2 WRITE (LU, 5) ARG1(1:L1), TMP3, TMP4 WRITE (LU, 2) TMP3, TMP1, TMP5 WRITE (LU, 2) TMP4, TMP2, TMP6 WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ENDIF ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (1) WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 2) ARG1(1:L1), TMP2, TMP3 WRITE (LU, 3) ARGX(1:4), TMP3, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ELSE C C (Arg1 is MPC) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (9) TMP6 = GETMP (1) TMP7 = GETMP (1) WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 4) TMP3 WRITE (LU, 5) ARG1(1:L1), TMP4, TMP5 WRITE (LU, 2) TMP4, TMP2, TMP6 WRITE (LU, 2) TMP5, TMP3, TMP7 WRITE (LU, 6) ARGX(1:4), TMP6, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP7, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) CALL RLTMP (TMP7) ENDIF ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (1) IF (ITP2 .EQ. 5) THEN WRITE (LU, 8) TMP1, ARG2(1:L2) WRITE (LU, 9) TMP2, ARG2(1:L2) ELSE WRITE (LU, 10) TMP1, ARG2(1:L2) WRITE (LU, 11) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 2) ARG1(1:L1), TMP3, TMP4 WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP2, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ELSE C C (Arg1 is MPC) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (9) TMP6 = GETMP (9) TMP7 = GETMP (1) TMP8 = GETMP (1) IF (ITP2 .EQ. 5) THEN WRITE (LU, 8) TMP1, ARG2(1:L2) WRITE (LU, 9) TMP2, ARG2(1:L2) ELSE WRITE (LU, 10) TMP1, ARG2(1:L2) WRITE (LU, 11) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 5) ARG1(1:L1), TMP5, TMP6 WRITE (LU, 2) TMP5, TMP3, TMP7 WRITE (LU, 2) TMP6, TMP4, TMP8 WRITE (LU, 6) ARGX(1:4), TMP7, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP8, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) CALL RLTMP (TMP7) CALL RLTMP (TMP8) ENDIF ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C TMP1 = GETMP (1) WRITE (LU, 2) ARG1(1:L1), ARG2(1:L2), TMP1 WRITE (LU, 3) ARGX(1:4), TMP1, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPC) and (Arg2 is MPI or MPR). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (1) TMP5 = GETMP (1) WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 4) TMP3 WRITE (LU, 2) TMP1, ARG2(1:L2), TMP4 WRITE (LU, 2) TMP2, TMP3, TMP5 WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP5, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (1) TMP5 = GETMP (1) WRITE (LU, 5) ARG2(1:L2), TMP1, TMP2 WRITE (LU, 4) TMP3 WRITE (LU, 2) ARG1(1:L1), TMP1, TMP4 WRITE (LU, 2) TMP3, TMP2, TMP5 WRITE (LU, 6) ARGX(1:4), TMP4, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP5, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ELSE C C (Arg1 is MPC) AND (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (1) TMP6 = GETMP (1) WRITE (LU, 5) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 5) ARG2(1:L2), TMP3, TMP4 WRITE (LU, 2) TMP1, TMP3, TMP5 WRITE (LU, 2) TMP2, TMP4, TMP6 WRITE (LU, 6) ARGX(1:4), TMP5, UOPR(IOP)(1:LOP(IOP)), $ ANDOR(1:5), TMP6, UOPR(IOP)(1:LOP(IOP)) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ENDIF GOTO 110 C C 100 CALL ERRMES (52, 0) WRITE (6, 12) UOPR(IOP)(1:LOP(IOP)) 12 FORMAT ('Operation ',A,' is not defined with these operands.') CALL ABRT C 110 RETURN END C SUBROUTINE GENDIV (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C This generates code for a divide operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C IF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is DP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (9) WRITE (LU, 1) ARG1(1:L1), TMP1 1 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 2) TMP1, ARG2(1:L2), ARGX(1:4) 2 FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) ELSE C C (Arg1 is DP) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (10) WRITE (LU, 1) ARG1(1:L1), TMP1 WRITE (LU, 3) TMP2 3 FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')') WRITE (LU, 4) TMP1, TMP2, TMP3 4 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') WRITE (LU, 5) TMP3, ARG2(1:L2), ARGX(1:4) 5 FORMAT (6X,'CALL MPCDIV (MPNW4, ',A,', ',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is IN or SP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (9) WRITE (LU, 6) TMP1, ARG1(1:L1) 6 FORMAT (6X,A,' = ',A) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 2) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is IN or SP) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (10) WRITE (LU, 6) TMP1, ARG1(1:L1) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 3) TMP3 WRITE (LU, 4) TMP2, TMP3, TMP4 WRITE (LU, 5) TMP4, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ENDIF ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is CO or DP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) IF (ITP1 .EQ. 5) THEN WRITE (LU, 7) TMP1, ARG1(1:L1) 7 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 8) TMP2, ARG1(1:L1) 8 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 9) TMP1, ARG1(1:L1) 9 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 10) TMP2, ARG1(1:L1) 10 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 2) TMP3, ARG2(1:L2), ARGX(1:4) WRITE (LU, 11) TMP4, ARG2(1:L2), ARGX(1:4) 11 FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,'(MPNWQ+5))') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ELSE C C (Arg1 is CO or DP) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP1 .EQ. 5) THEN WRITE (LU, 7) TMP1, ARG1(1:L1) WRITE (LU, 8) TMP2, ARG1(1:L1) ELSE WRITE (LU, 9) TMP1, ARG1(1:L1) WRITE (LU, 10) TMP2, ARG1(1:L1) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 4) TMP3, TMP4, TMP5 WRITE (LU, 12) TMP5, ARG2(1:L2), ARGX(1:4) 12 FORMAT (6X,'CALL MPCDIV (MPNW4, ',A,', ',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is DP). C WRITE (LU, 13) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) 13 FORMAT (6X,'CALL MPDIVD (',A,', ',A,', 0, ',A,')') ELSE C C (Arg1 is MPC) and (Arg2 is DP). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2 14 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (LU, 13) TMP1, ARG2(1:L2), ARGX(1:4) WRITE (LU, 15) TMP2, ARG2(1:L2), ARGX(1:4) 15 FORMAT (6X,'CALL MPDIVD (',A,', ',A,', 0, ',A, $ '(MPNWQ+5))') CALL RLTMP (TMP1) CALL RLTMP (TMP2) ENDIF ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is IN or SP). C TMP1 = GETMP (3) WRITE (LU, 6) TMP1, ARG2(1:L2) WRITE (LU, 13) ARG1(1:L1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) ELSE C C (Arg1 is MPC) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 6) TMP1, ARG2(1:L2) WRITE (LU, 14) ARG1(1:L1), TMP2, TMP3 WRITE (LU, 13) TMP2, TMP1, ARGX(1:4) WRITE (LU, 15) TMP3, TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) TMP6 = GETMP (10) IF (ITP2 .EQ. 5) THEN WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP2, ARG2(1:L2) ELSE WRITE (LU, 9) TMP1, ARG2(1:L2) WRITE (LU, 10) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 4) TMP3, TMP4, TMP5 WRITE (LU, 3) TMP3 WRITE (LU, 4) ARG1(1:L1), TMP3, TMP6 WRITE (LU, 12) TMP6, TMP5, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ELSE C C (Arg1 is MPC) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP2 .EQ. 5) THEN WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP2, ARG2(1:L2) ELSE WRITE (LU, 9) TMP1, ARG2(1:L2) WRITE (LU, 10) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 1) TMP1, TMP3 WRITE (LU, 1) TMP2, TMP4 WRITE (LU, 4) TMP3, TMP4, TMP5 WRITE (LU, 12) ARG1(1:L1), TMP5, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C WRITE (LU, 2) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPC) and (Arg2 is MPI or MPR). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 2) TMP1, ARG2(1:L2), ARGX(1:4) WRITE (LU, 11) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (10) WRITE (LU, 3) TMP1 WRITE (LU, 4) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 12) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPC) and (Arg2 is MPC). C WRITE (LU, 12) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ENDIF C RETURN END C SUBROUTINE GENEXP (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C This generates code for an exponentiation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C IOP = 4 IF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3 .AND. ITP2 .EQ. 8) THEN C C (Arg1 is DP) and (Arg2 is MPI). C KCON(3) = 1 TMP1 = GETMP (9) TMP2 = GETMP (8) TMP3 = GETMP (3) TMP4 = GETMP (1) TMP5 = GETMP (9) TMP6 = GETMP (9) WRITE (LU, 1) ARG1(1:L1), TMP1 1 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 2) ARG2(1:L2), TMP2 2 FORMAT (6X,'CALL MPEQ (',A,', ',A,')') WRITE (LU, 3) TMP2, TMP2 3 FORMAT (6X,'IF (',A,'(2) .EQ. 0. .OR. ',A,'(2) .EQ. 1) THEN') WRITE (LU, 4) TMP2, TMP3, TMP4 4 FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')') WRITE (LU, 5) TMP4, TMP3, TMP4 5 FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A,' + 0.25D0') WRITE (LU, 6) TMP1, TMP4, ARGX(1:4) 6 FORMAT (6X,'CALL MPNPWR (',A,', ',A,', ',A,')') WRITE (LU, 7) 7 FORMAT (6X,'ELSE') WRITE (LU, 8) TMP1, TMP5 8 FORMAT (6X,'CALL MPLOG (',A,', MPL02, ',A,')') WRITE (LU, 9) ARG2(1:L2), TMP5, TMP6 9 FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')') WRITE (LU, 10) TMP6, ARGX(1:4) 10 FORMAT (6X,'CALL MPEXP (',A,', MPL02, ',A,')') WRITE (LU, 11) 11 FORMAT (6X,'ENDIF') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ELSEIF (ITP1 .EQ. 3 .AND. ITP2 .EQ. 9) THEN C C (Arg1 is DP) and (Arg2 is MPR). C KCON(3) = 1 TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 1) ARG1(1:L1), TMP1 WRITE (LU, 8) TMP1, TMP2 WRITE (LU, 9) ARG2(1:L2), TMP2, TMP3 WRITE (LU, 10) TMP3, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ELSEIF ((ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) .AND. ITP2 .EQ. 8) THEN C C (Arg1 is IN or SP) and (Arg2 is MPI). C KCON(3) = 1 TMP1 = GETMP (9) TMP2 = GETMP (8) TMP3 = GETMP (3) TMP4 = GETMP (1) TMP5 = GETMP (9) TMP6 = GETMP (9) WRITE (LU, 12) TMP3, ARG1(1:L1) 12 FORMAT (6X,A,' = ',A) WRITE (LU, 1) TMP3, TMP1 WRITE (LU, 2) ARG2(1:L2), TMP2 WRITE (LU, 3) TMP2, TMP2 WRITE (LU, 4) TMP2, TMP3, TMP4 WRITE (LU, 5) TMP4, TMP3, TMP4 WRITE (LU, 6) TMP1, TMP4, ARGX(1:4) WRITE (LU, 7) WRITE (LU, 8) TMP1, TMP5 WRITE (LU, 9) ARG2(1:L2), TMP5, TMP6 WRITE (LU, 10) TMP6, ARGX(1:4) WRITE (LU, 11) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) CALL RLTMP (TMP6) ELSEIF ((ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) .AND. ITP2 .EQ. 9) THEN C C (Arg1 is IN or SP) and (Arg2 is MPI or MPR). C KCON(3) = 1 TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) WRITE (LU, 13) TMP1, ARG1(1:L1) 13 FORMAT (6X,A,' = ',A) WRITE (LU, 1) TMP1, TMP2 WRITE (LU, 8) TMP2, TMP3 WRITE (LU, 9) ARG2(1:L2), TMP3, TMP4 WRITE (LU, 10) TMP4, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ELSE GOTO 100 ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP1 .NE. 10 .AND. ITP2 .EQ. 1) THEN C C (Arg1 is MPI or MPR) and (Arg2 is IN). C WRITE (LU, 14) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) 14 FORMAT (6X,'CALL MPNPWR (',A,', ',A,', ',A,')') ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 1) THEN C C (Arg1 is MPC) and (Arg2 is IN). This is the only permissible C exponentiation with a MPC operand. C WRITE (LU, 15) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) 15 FORMAT (6X, 'CALL MPCPWR (MPNW4, ',A,', ',A,', ',A,')') ELSEIF (ITP1 .NE. 10 .AND. (ITP2 .EQ. 2 .OR. ITP2 .EQ. 3)) $ THEN C C (Arg1 is MPI or MPR) and (Arg2 is SP or DP). C KCON(3) = 1 TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) WRITE (LU, 13) TMP1(1:4), ARG2(1:L2) WRITE (LU, 1) TMP1(1:4), TMP2 WRITE (LU, 8) ARG1(1:L1), TMP3 WRITE (LU, 9) TMP2, TMP3, TMP4 WRITE (LU, 10) TMP4, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ELSE GOTO 100 ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 8) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI). C KCON(3) = 1 TMP1 = GETMP (8) TMP2 = GETMP (3) TMP3 = GETMP (1) TMP4 = GETMP (9) TMP5 = GETMP (9) WRITE (LU, 2) ARG2(1:L2), TMP1 WRITE (LU, 3) TMP1, TMP1 WRITE (LU, 4) TMP1, TMP2, TMP3 WRITE (LU, 5) TMP3, TMP2, TMP3 WRITE (LU, 6) ARG1(1:L1), TMP3, ARGX(1:4) WRITE (LU, 7) WRITE (LU, 8) ARG1(1:L1), TMP4 WRITE (LU, 9) ARG2(1:L2), TMP4, TMP5 WRITE (LU, 10) TMP5, ARGX(1:4) WRITE (LU, 11) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 9) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C KCON(3) = 1 TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 8) ARG1(1:L1), TMP1 WRITE (LU, 9) ARG2(1:L2), TMP1, TMP2 WRITE (LU, 10) TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ENDIF GOTO 110 C 100 CALL ERRMES (53, 0) WRITE (6, 16) UOPR(IOP)(1:LOP(IOP)) 16 FORMAT ('Operation ',A,' is not defined with these operands.') CALL ABRT C 110 RETURN END C SUBROUTINE GENMUL (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C This generates code for a multiply operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C IF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is DP) and (Arg2 is MPI or MPR). C WRITE (LU, 1) ARG2(1:L2), ARG1(1:L1), ARGX(1:4) 1 FORMAT (6X,'CALL MPMULD (',A,', ',A,', 0, ',A,')') ELSE C C (Arg1 is DP) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 2) ARG2(1:L2), TMP1, TMP2 2 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (LU, 1) TMP1, ARG1(1:L1), ARGX(1:4) WRITE (LU, 3) TMP2, ARG1(1:L1), ARGX(1:4) 3 FORMAT (6X,'CALL MPMULD (',A,', ',A,', 0, ',A, $ '(MPNWQ+5))') CALL RLTMP (TMP1) CALL RLTMP (TMP2) ENDIF ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is IN or SP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) WRITE (LU, 4) TMP1, ARG1(1:L1) 4 FORMAT (6X,A,' = ',A) WRITE (LU, 1) ARG2(1:L2), TMP1, ARGX(1:4) CALL RLTMP (TMP1) ELSE C C (Arg1 is IN or SP) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 4) TMP1, ARG1(1:L1) WRITE (LU, 2) ARG2(1:L2), TMP2, TMP3 WRITE (LU, 1) TMP2, TMP1, ARGX(1:4) WRITE (LU, 3) TMP3, TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ELSEIF (ITP1 .EQ. 4 .OR. ITP1 .EQ. 5) THEN IF (ITP2 .NE. 10) THEN C C (Arg1 is CO or DP) and (Arg2 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (3) IF (ITP1 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG1(1:L1) 5 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 6) TMP2, ARG1(1:L1) 6 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 7) TMP1, ARG1(1:L1) 7 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 8) TMP2, ARG1(1:L1) 8 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 1) ARG2(1:L2), TMP1, ARGX(1:4) WRITE (LU, 3) ARG2(1:L2), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is CO or DP) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP1 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG1(1:L1) WRITE (LU, 6) TMP2, ARG1(1:L1) ELSE WRITE (LU, 7) TMP1, ARG1(1:L1) WRITE (LU, 8) TMP2, ARG1(1:L1) ENDIF WRITE (LU, 9) TMP1, TMP3 9 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 9) TMP2, TMP4 WRITE (LU, 10) TMP3, TMP4, TMP5 10 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') WRITE (LU, 11) TMP5, ARG2(1:L2), ARGX(1:4) 11 FORMAT (6X,'CALL MPCMUL (MPNW4, ',A,', ',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is DP). C WRITE (LU, 1) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ELSE C C (Arg1 is MPC) and (Arg2 is DP). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 1) TMP1, ARG2(1:L2), ARGX(1:4) WRITE (LU, 3) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ENDIF ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is IN or SP). C TMP1 = GETMP (3) WRITE (LU, 4) TMP1, ARG2(1:L2) WRITE (LU, 1) ARG1(1:L1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) ELSE C C (Arg1 is MPC) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 4) TMP1, ARG2(1:L2) WRITE (LU, 2) ARG1(1:L1), TMP2, TMP3 WRITE (LU, 1) TMP2, TMP1, ARGX(1:4) WRITE (LU, 3) TMP3, TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ELSEIF (ITP2 .EQ. 4 .OR. ITP2 .EQ. 5) THEN IF (ITP1 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) IF (ITP2 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG2(1:L2) WRITE (LU, 6) TMP2, ARG2(1:L2) ELSE WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 1) ARG1(1:L1), TMP1, ARGX(1:4) WRITE (LU, 3) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MPC) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP2 .EQ. 5) THEN WRITE (LU, 5) TMP1, ARG2(1:L2) WRITE (LU, 6) TMP2, ARG2(1:L2) ELSE WRITE (LU, 7) TMP1, ARG2(1:L2) WRITE (LU, 8) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 9) TMP1, TMP3 WRITE (LU, 9) TMP2, TMP4 WRITE (LU, 10) TMP3, TMP4, TMP5 WRITE (LU, 11) ARG1(1:L1), TMP5, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C WRITE (LU, 12) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) 12 FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')') ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPC) and (Arg2 is MPI or MPR). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 2) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 12) TMP1, ARG2(1:L2), ARGX(1:4) WRITE (LU, 13) TMP2, ARG2(1:L2), ARGX(1:4) 13 FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,'(MPNWQ+5))') CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPC). C TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 2) ARG2(1:L2), TMP1, TMP2 WRITE (LU, 12) ARG1(1:L1), TMP1, ARGX(1:4) WRITE (LU, 13) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPC) and (Arg2 is MPC). C WRITE (LU, 11) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ENDIF C RETURN END C SUBROUTINE GENSUB (LU, ITP1, L1, ARG1, ITP2, L2, ARG2, ARGX) C C This generates code for a subtract operation. The operands are in ARG1 and C ARG2, with types ITP1 and ITP2, and with lengths L1 and L2. The result C name is in ARGX (also input). LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG2, ARGX CHARACTER*4 TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, TMP7, TMP8, GETMP C IF (ITP1 .EQ. 0) THEN C C Handle the negation of a MP entity. C IF (ITP2 .NE. 10) THEN C C Arg2 is MPI or MPR. C WRITE (LU, 1) ARG2(1:L2), ARGX(1:4) 1 FORMAT (6X,'CALL MPEQ (',A,', ',A,')') WRITE (LU, 2) ARGX(1:4), ARGX(1:4) 2 FORMAT (6X,A,'(1) = - ',A,'(1)') ELSE C C Arg2 is MPC. C WRITE (LU, 3) ARG2(1:L2), ARGX(1:4) 3 FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')') WRITE (LU, 2) ARGX(1:4), ARGX(1:4) WRITE (LU, 4) ARGX(1:4), ARGX(1:4) 4 FORMAT (6X,A,'(MPNWQ+5) = - ',A,'(MPNWQ+5)') ENDIF ELSEIF (ITP1 .LT. 8) THEN IF (ITP1 .EQ. 3) THEN C C (Arg1 is DP) and (Arg2 is MP). C TMP1 = GETMP (9) IF (ITP2 .EQ. 10) THEN WRITE (LU, 5) ARG2(1:L2), ARGX(1:4) 5 FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')') ENDIF WRITE (LU, 6) ARG1(1:L1), TMP1 6 FORMAT (6X,'CALL MPDMC (',A,', 0, ',A,')') WRITE (LU, 7) TMP1, ARG2(1:L2), ARGX(1:4) 7 FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) ELSEIF (ITP1 .EQ. 1 .OR. ITP1 .EQ. 2) THEN C C (Arg1 is IN or SP) and (Arg2 is MP). C TMP1 = GETMP (3) TMP2 = GETMP (9) IF (ITP2 .EQ. 10) THEN WRITE (LU, 5) ARG2(1:L2), ARGX(1:4) ENDIF WRITE (LU, 8) TMP1, ARG1(1:L1) 8 FORMAT (6X,A,' = ',A) WRITE (LU, 6) TMP1, TMP2 WRITE (LU, 9) TMP2, ARG2(1:L2), ARGX(1:4) 9 FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is CO or DC) and (Arg2 is MP). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP1 .EQ. 5) THEN WRITE (LU, 10) TMP1, ARG1(1:L1) 10 FORMAT (6X,A,' = DREAL (',A,')') WRITE (LU, 11) TMP2, ARG1(1:L1) 11 FORMAT (6X,A,' = DIMAG (',A,')') ELSE WRITE (LU, 12) TMP1, ARG1(1:L1) 12 FORMAT (6X,A,' = REAL (',A,')') WRITE (LU, 13) TMP2, ARG1(1:L1) 13 FORMAT (6X,A,' = AIMAG (',A,')') ENDIF WRITE (LU, 6) TMP1, TMP3 WRITE (LU, 6) TMP2, TMP4 WRITE (LU, 14) TMP3, TMP4, TMP5 14 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') IF (ITP2 .EQ. 10) THEN WRITE (LU, 15) TMP5, ARG2(1:L2), ARGX(1:4) 15 FORMAT (6X,'CALL MPCSUB (MPNW4, ',A,', ',A,', ',A,')') ELSE TMP6 = GETMP (10) WRITE (LU, 16) TMP3 16 FORMAT (6X,'CALL MPDMC (0.D0, 0, ',A,')') WRITE (LU, 14) ARG2(1:L2), TMP3, TMP6 WRITE (LU, 15) TMP5, TMP6, ARGX(1:4) CALL RLTMP (TMP6) ENDIF CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ELSEIF (ITP2 .LT. 8) THEN IF (ITP2 .EQ. 3) THEN C C (Arg1 is MP) and (Arg2 is DP). C TMP1 = GETMP (9) IF (ITP1 .EQ. 10) THEN WRITE (LU, 5) ARG1(1:L1), ARGX(1:4) ENDIF WRITE (LU, 6) ARG2(1:L2), TMP1 WRITE (LU, 7) ARG1(1:L1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) ELSEIF (ITP2 .EQ. 1 .OR. ITP2 .EQ. 2) THEN C C (Arg1 is MP) and (Arg2 is IN or SP). C TMP1 = GETMP (3) TMP2 = GETMP (9) IF (ITP1 .EQ. 10) THEN WRITE (LU, 5) ARG1(1:L1), ARGX(1:4) ENDIF WRITE (LU, 8) TMP1, ARG2(1:L2) WRITE (LU, 6) TMP1, TMP2 WRITE (LU, 7) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MP) and (Arg2 is CO or DC). C TMP1 = GETMP (3) TMP2 = GETMP (3) TMP3 = GETMP (9) TMP4 = GETMP (9) TMP5 = GETMP (10) IF (ITP2 .EQ. 5) THEN WRITE (LU, 10) TMP1, ARG2(1:L2) WRITE (LU, 11) TMP2, ARG2(1:L2) ELSE WRITE (LU, 12) TMP1, ARG2(1:L2) WRITE (LU, 13) TMP2, ARG2(1:L2) ENDIF WRITE (LU, 6) TMP1, TMP3 WRITE (LU, 6) TMP2, TMP4 WRITE (LU, 14) TMP3, TMP4, TMP5 IF (ITP1 .EQ. 10) THEN WRITE (LU, 15) ARG1(1:L1), TMP5, ARGX(1:4) ELSE TMP6 = GETMP (10) WRITE (LU, 16) TMP3 WRITE (LU, 14) ARG1(1:L1), TMP3, TMP6 WRITE (LU, 15) TMP6, TMP5, ARGX(1:4) CALL RLTMP (TMP6) ENDIF CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) ENDIF ELSEIF (ITP1 .NE. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPI or MPR). C WRITE (LU, 9) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ELSEIF (ITP1 .NE. 10 .AND. ITP2 .EQ. 10) THEN C C (Arg1 is MPI or MPR) and (Arg2 is MPC). C TMP1 = GETMP (3) TMP2 = GETMP (10) WRITE (LU, 16) TMP1 WRITE (LU, 14) ARG1(1:L1), TMP1, TMP2 WRITE (LU, 15) TMP2, ARG2(1:L2), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSEIF (ITP1 .EQ. 10 .AND. ITP2 .NE. 10) THEN C C (Arg1 is MPC) and (Arg1 is MPI or MPR). C TMP1 = GETMP (3) TMP2 = GETMP (10) WRITE (LU, 16) TMP1 WRITE (LU, 14) ARG2(1:L2), TMP1, TMP2 WRITE (LU, 15) ARG1(1:L1), TMP2, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) ELSE C C (Arg1 is MPC) and (Arg2 is MPC). C WRITE (LU, 15) ARG1(1:L1), ARG2(1:L2), ARGX(1:4) ENDIF C RETURN END C SUBROUTINE GENFUN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX, $ LX, ARGX) C C This generates code for a function reference. The function name is ARG1, C with type ITP1 and length L1. NAR is the number of arguments. The C argument list is input in ARG, with types in ITAR and lengths in LAR. C The result is placed in ARGX, with type in ITPX and length in LX. LU is C the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINY CHARACTER*80 ARG1, ARG(MAR), ARGI, ARGJ, ARGX CHARACTER*16 NAM, NAMQ, UCASE DIMENSION ITAR(MAR), LAR(MAR) CHARACTER*4 GETMP, TMP1 C* C write (lu, *) 'enter genfun nar, arg1 =', nar, C $ ' %'//arg1(1:l1)//'%' C write (lu, '(2i4,2x,a)') (i, itar(i), arg(i)(1:lar(i)), C $ i = 1, nar) C* NAMQ = 'DPNRT' IQNRT = ITAB (0, 0, NAMQ) NAMQ = 'MPINT' IQINT = ITAB (0, 0, NAMQ) NAMQ = 'ABS' IQABS = ITAB (0, 0, NAMQ) NAMQ = 'NINT' IQNINT = ITAB (0, 0, NAMQ) C C Check if this function is one of the obsolescent type-specific intrinsics. C NAMQ = UCASE (ARG1(1:L1)) C DO 100 I = 1, NSF IF (SFUN(I) .EQ. NAMQ) THEN CALL ERRMES (54, 0) WRITE (6, 1) ARG1(1:L1) 1 FORMAT ('This type-specific Fortran intrinsic function is', $ ' not allowed: ',A/'Replace with the equivalent Fortran', $ ' generic function.') CALL ABRT ENDIF 100 CONTINUE C C Find the function name in the symbol table. C LL = MIN (L1, 16) NAM = ARG1(1:LL) IX = ITAB (0, 0, NAM) IF (IX .EQ. 0) CALL ERRMES (55, 1) IF (IX .GT. MINT) CALL CHKARG (LU, NAM, NAR, ITAR, LAR, ARG) C C Check if this is a reference to an intrisic function. C IF (IX .LE. MINT) THEN C C Check if the mixed mode safe option is in effect. C IF (IMM .GE. 1) THEN C C Convert any non-MP arguments to MP. C DO 110 I = 1, NAR ITPI = ITAR(I) LI = LAR(I) ARGI(1:LI) = ARG(I)(1:LI) IF (IX .EQ. IQNRT .AND. I .EQ. 2) GOTO 110 IF (ITPI .EQ. 1) THEN ITPJ = 8 ELSEIF (ITPI .EQ. 2 .OR. ITPI .EQ. 3) THEN ITPJ = 9 ELSEIF (ITPI .EQ. 4 .OR. ITPI .EQ. 5) THEN ITPJ = 10 ELSE GOTO 110 ENDIF LJ = 4 ARGJ(1:4) = GETMP (ITPJ) CALL GENASN (LU, ITPJ, LJ, ARGJ, ITPI, LI, ARGI) IF (LI .EQ. 4) THEN IF (ARGI(1:2) .EQ. 'MP') THEN TMP1 = ARGI(1:4) CALL RLTMP (TMP1) ENDIF ENDIF C C Substitute the new argument (a MP temporary) for the old. C ITAR(I) = ITPJ LAR(I) = 4 ARG(I)(1:4) = ARGJ(1:4) 110 CONTINUE C ENDIF ITM = 0 C C Determine if any arguments are of a MP type. C DO 120 I = 1, NAR IF (ITAR(I) .GE. 8) ITM = 1 120 CONTINUE C C Call INTRIN for intrinsic calls with MP arguments. Other intrinsic C references will be handled in this routine. C IF (ITM .NE. 0 .OR. IX .GE. IQINT) THEN CALL INTRIN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX, $ LX, ARGX) GOTO 150 ELSEIF (ITP1 .EQ. -1) THEN C C Except for ABS with a complex or double complex argument, and NINT, the C result type of a Fortran-77 intrinsic functions with an argument-dependent C type is the type of the first argument. C IF (IX .EQ. IQABS) THEN IF (ITAR(1) .EQ. 4) THEN ITPX = 2 ELSEIF (ITAR(1) .EQ. 5) THEN ITPX = 3 ELSE ITPX = ITAR(1) ENDIF ELSEIF (IX .EQ. IQNINT) THEN ITPX = 1 ELSE ITPX = ITAR(1) ENDIF ELSE ITPX = ITP1 ENDIF ELSE C C For all other cases, set the result to be a temporary of type ITP1. C ITPX = ITP1 ENDIF C IF (LU .EQ. 12 .AND. IX .GT. MINT) THEN CALL ERRMES (56, 0) WRITE (6, 2) 2 FORMAT ('Only intrinsic functions may appear in a parameter', $ ' statement.') CALL ABRT ENDIF C LX = 4 ARGX = GETMP (ITPX) C C Check if this is an ordinary function reference of type MP. If so, C generate a call statement. C IF (ITP1 .GE. 8) THEN LINY(1:11) = ' CALL ' LINY(12:L1+11) = ARG1(1:L1) LINY(L1+12:L1+13) = ' (' LY = L1 + 13 C C Append the argument list. C DO 130 I = 1, NAR LI = LAR(I) LINY(LY+1:LY+LI) = ARG(I)(1:LI) LINY(LY+LI+1:LY+LI+2) = ', ' LY = LY + LI + 2 130 CONTINUE C C Set the last argument of the call statement to be the result temporary C name. C LINY(LY+1:LY+4) = ARGX(1:4) LINY(LY+5:LY+5) = ')' LY = LY + 5 C C Check if it is a non-MP function reference. If so, generate an assignment C statement. C ELSE LINY(1:6) = ' ' LINY(7:10) = ARGX(1:4) LINY(11:13) = ' = ' LINY(14:L1+13) = ARG1(1:L1) LINY(L1+14:L1+15) = ' (' LY = L1 + 15 C C Append the argument list. C DO 140 I = 1, NAR LI = LAR(I) LINY(LY+1:LY+LI) = ARG(I)(1:LI) LINY(LY+LI+1:LY+LI+2) = ', ' LY = LY + LI + 2 140 CONTINUE C IF (NAR .EQ. 0) THEN LY = LY + 1 ELSE LY = LY - 1 ENDIF LINY(LY:LY) = ')' C ENDIF C IF (LU .EQ. 11) THEN CALL OUTLIN (1, LY, LINY) ELSE CALL OUTLIN (3, LY, LINY) ENDIF C C Release any temporaries among the arguments. C 150 DO 160 I = 1, NAR LI = LAR(I) IF (LI .EQ. 4) THEN IF (ARG(I)(1:2) .EQ. 'MP') THEN TMP1 = ARG(I)(1:4) CALL RLTMP (TMP1) ENDIF ENDIF 160 CONTINUE C* C write (lu, *) 'exit genfun itpx, argx =', itpx, C $ ' %'//argx(1:lx)//'%' C* RETURN END C FUNCTION GETMP (ITP) C C This returns a temporary variable name that is of type ITP. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*4 GETMP CHARACTER*16 NAM C IF (ITP .LE. 0 .OR. ITP .GT. 11) THEN CALL ERRMES (57, 0) WRITE (6, 1) 1 FORMAT ('Improper type input to GETMP.') CALL ABRT ENDIF C C The two character types don't need to be put in the table, since they are C never retained after definition. C IF (ITP .EQ. 6) THEN GETMP = 'MPA1' GOTO 120 ELSEIF (ITP .EQ. 11) THEN GETMP = 'MPA2' GOTO 120 ENDIF C DO 100 I = 1, 9 IF (ITMP(I,ITP) .EQ. 0) GOTO 110 100 CONTINUE C CALL ERRMES (58, 0) WRITE (6, 2) 2 FORMAT ('Statement is too complicated.') CALL ABRT C 110 ITMP(I,ITP) = 1 WRITE (GETMP, 3) CTM(ITP), I 3 FORMAT ('MP',A1,I1) C 120 NAM = GETMP IX = ITAB (2, ITP, NAM) C RETURN END C SUBROUTINE IFST (IFL, IFS, K1, LN) C C This handles MP IF and ELSEIF statements. K1 is the index of the left C parenthesis, and LN is the last non-blank character in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*80 ARGX CHARACTER*16 LINQ, UCASE CHARACTER*4 TMP1 C C If this is an elseif statement, increase the IFL counter and output an C else statement. C IF (IFS .EQ. 2) THEN IFL = IFL + 1 WRITE (11, 1) 1 FORMAT (6X,'ELSE') ENDIF C C Locate the matching right parenthesis of the left parenthesis. C J1 = K1 J2 = MATCH (0, J1 + 1, LN, LINE) C C Determine whether the expression inside the parentheses and the expression C following the parentheses have MP variables. C I1 = ISCAN (J1, J2, LINE) IF (I1 .NE. 0) CALL FIXSUB (J1, J2, LN) J3 = NBLK (J2 + 1, LN, LINE) LQ = MIN (J3 + 15, LN) LINQ = UCASE (LINE(J3:LQ)) IF (J3 + 3 .EQ. LN .AND. LINQ(1:4) .EQ. 'THEN') THEN I2 = 0 ITH = 1 ELSE I2 = ISCAN (J3, LN, LINE) J4 = LN IF (I2 .NE. 0) CALL FIXSUB (J3, J4, LN) ITH = 0 ENDIF C C If the expression inside parentheses has no MP variables, there is no C need to process it. C IF (I1 .EQ. 0) THEN LA = J2 LINA(1:LA) = LINE(1:LA) CALL OUTLIN (1, LA, LINA) WRITE (11, 2) 2 FORMAT (5X,'$ THEN') ELSE C C Process the expression inside parentheses. C LA = J2 - J1 - 1 LINA(1:LA) = LINE(J1+1:J2-1) CALL EXPRES (11, LA, LINA, ITPX, LX, ARGX) C C Check if the result of the expression in parentheses is of type logical. C IF (ITPX .NE. 7) THEN CALL ERRMES (59, 0) WRITE (6, 3) 3 FORMAT ('Result of expression in parentheses is not of type', $ ' logical.') CALL ABRT ENDIF C C Output IF statement with the resulting logical variable. C WRITE (11, 4) ARGX(1:LX) 4 FORMAT (6X,'IF (',A,') THEN') C C Release final logical temporary variable. C TMP1 = ARGX(1:LX) CALL RLTMP (TMP1) ENDIF C C If the expression following the parentheses is merely THEN, then we are C done. C IF (ITH .EQ. 1) GOTO 100 C C If the expression following the parentheses has no MP variables, then C it does not need to be processed. C IF (I2 .EQ. 0) THEN LA = LN - J2 + 6 LINA(1:6) = ' ' LINA(7:LA) = LINE(J2+1:LN) CALL OUTLIN (1, LA, LINA) ELSE C C Process the executable MP expression after the parentheses. C J1 = J2 + 1 IF (J1 .GT. LN) CALL ERRMES (60, 1) J1 = NBLK (J1, LN, LINE) CALL EXEC (J1, LN) ENDIF C WRITE (11, 5) 5 FORMAT (6X,'ENDIF') C 100 RETURN END C SUBROUTINE IMPLIC (K1, LN) C C This handles IMPLICIT statements. K1 and LN are the indices of the C first (after 'IMPLICIT') and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*16 LINQ, UCASE CHARACTER*1 CJ C C Check if this is an implicit 'none' statement. C J1 = K1 IF (J1 + 3 .EQ. LN) THEN LINQ = UCASE (LINE(J1:LN)) IF (LINQ(1:4) .EQ. 'NONE') THEN C DO 100 I = 1, 26 IF (IMPL(I) .LE. 7) IMPL(I) = 0 100 CONTINUE C GOTO 130 ENDIF ENDIF IT = NTYPE (J1, LN) J1 = INDX (J1, LN, '(', LINE) IF (IT .EQ. 0 .OR. J1 .EQ. 0) CALL ERRMES (61, 1) C C Process a normal implicit statement. C 110 J1 = NBLK (J1 + 1, LN, LINE) CJ = LINE(J1:J1) IF (CJ .EQ. '(') GOTO 110 IF (CJ .EQ. ',') GOTO 110 IF (CJ .EQ. ')') GOTO 130 I1 = MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) IF (J1 .EQ. 0 .OR. I1 .EQ. 0) CALL ERRMES (62, 1) IF (IMPL(I1) .LE. 7) IMPL(I1) = IT J2 = NBLK (J1 + 1, LN, LINE) CJ = LINE(J2:J2) IF (CJ .EQ. '-') THEN J2 = NBLK (J2 + 1, LN, LINE) CJ = LINE(J2:J2) I2 = MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) IF (I2 .EQ. 0) CALL ERRMES (63, 1) C DO 120 I = I1, I2 IF (IMPL(I) .LE. 7) IMPL(I) = IT 120 CONTINUE C J1 = J2 ENDIF GOTO 110 C 130 RETURN END C FUNCTION INDX (K1, K2, CX, LINA) C C Finds the index of the first instance of character CX in LINA between C positions K1 and K2. C CHARACTER*1600 LINA CHARACTER*1 CX C DO 100 I = K1, K2 IF (LINA(I:I) .EQ. CX) GOTO 110 100 CONTINUE C I = 0 110 INDX = I C RETURN END C SUBROUTINE INIMP C C This generates declaration and initialization code for MP routines. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 LIN CHARACTER*16 NAM CHARACTER*8 NUM1, NUM2, NUM3, NUM4, NUMX C C Optionally print out the symbol table for this subprogram. C* C write (6, '(4i4,2x,a)') (i, ktyp(i), kdim(i), lvar(i), C $ '%'//var(i)(1:lvar(i))//'%', i = mint + 1, nvar) C* C Place the character and MP dimensions into character variables. C WRITE (NUMX, '(I8)') MXP + 4 I1 = NBLK (1, 8, NUMX) N1 = 9 - I1 NUM1 = NUMX(I1:8) WRITE (NUMX, '(I8)') 2 * MXP + 8 I1 = NBLK (1, 8, NUMX) N2 = 9 - I1 NUM2 = NUMX(I1:8) WRITE (NUMX, '(I8)') INT (7.225 * MXP) + 100 I1 = NBLK (1, 8, NUMX) N3 = 9 - I1 NUM3 = NUMX(I1:8) WRITE (NUMX, '(I8)') LSM + 4 I1 = NBLK (1, 8, NUMX) N4 = 9 - I1 NUM4 = NUMX(I1:8) C C If this is the main program, make sure that at least one MPR temporary C is defined. C IF (ISTP .EQ. 1) THEN NAM = 'MPM1' IX = ITAB (2, 9, NAM) ENDIF C C Insert declarations variables that do not yet have valid declarations. C These include, for example, the temporaries generated by GETMP. C DO 100 I = MINT + 1, NVAR KDM = KDIM(I) KTP = KTYP(I) LV = LVAR(I) NAM = VAR(I) IF (KDEC(I) .EQ. 0) THEN IF (KTP .EQ. 1) THEN WRITE (6, 1) NAM(1:LV) 1 FORMAT (6X,'INTEGER ',A) ELSEIF (KTP .EQ. 2) THEN WRITE (6, 2) NAM(1:LV) 2 FORMAT (6X,'REAL ',A) ELSEIF (KTP .EQ. 3) THEN WRITE (6, 3) NAM(1:LV) 3 FORMAT (6X,'DOUBLE PRECISION ',A) ELSEIF (KTP .EQ. 4) THEN WRITE (6, 4) NAM(1:LV) 4 FORMAT (6X,'COMPLEX ',A) ELSEIF (KTP .EQ. 5) THEN WRITE (6, 5) NAM(1:LV) 5 FORMAT (6X,'DOUBLE COMPLEX ',A) ELSEIF (KTP .EQ. 6) THEN WRITE (6, 6) NAM(1:LV), NUM3(1:N3) 6 FORMAT (6X,'CHARACTER*1 ',A,'(',A,')') ELSEIF (KTP .EQ. 7) THEN WRITE (6, 7) NAM(1:LV) 7 FORMAT (6X, 'LOGICAL ',A) C C For MP dimensioned variables, only declare the type as real. C ELSEIF (KDM .GT. 0) THEN WRITE (6, 8) NAM(1:LV) 8 FORMAT (6X,'REAL ',A) C C For MP scalar variables, declare as real with the appropriate dimension. C ELSEIF (KTP .EQ. 8 .OR. KTP .EQ. 9) THEN WRITE (6, 9) NAM(1:LV), NUM1(1:N1) 9 FORMAT (6X,'REAL ',A,'(',A,')') ELSEIF (KTP .EQ. 10) THEN WRITE (6, 9) NAM(1:LV), NUM2(1:N2) ELSEIF (KTP .EQ. 11) THEN WRITE (6, 10) NUM4(1:N4), NAM(1:LV) 10 FORMAT (6X,'CHARACTER*',A,' ',A) ENDIF ENDIF C C If the variable is a parameter, save it. C IF (KDM .EQ. -3) WRITE (6, 11) NAM(1:LV) 11 FORMAT (6X,'SAVE ',A) 100 CONTINUE C C Insert declarations for MPNWQ, MPNW4, MPL02, MPL10 and MPPIC if any is C required in this subprogram. C IF (ISTP .EQ. 1 .OR. KCON(1) .NE. 0 .OR. KCON(3) .NE. 0 .OR. $ KCON(4) .NE. 0 .OR. KCON(5) .NE. 0) $ WRITE (6, 12) (NUM1(1:N1), I = 1, 3) 12 FORMAT (6X,'INTEGER MPNWQ, MPNW4'/6X,'REAL MPL02, MPL10, MPPIC'/ $ 6X,'COMMON /MPTCON/ MPNWQ, MPNW4, MPL02(',A,'), MPL10(',A, $ '), MPPIC(',A,')') C C Insert declaration for MPEPS if it is required. C IF (KCON(2) .NE. 0) WRITE (6, 13) 13 FORMAT (6X,'REAL MPEPS(8)') C C If the scratch space directive is in effect, insert allocation. C IF (ISTP .EQ. 1 .AND. MSS .NE. 0) WRITE (6, 14) MSS 14 FORMAT (6X,'REAL MPSS'/6X,'COMMON /MPCOM3/ MPSS(',I8,')') C C If the precision level is very high, insert allocation for DP scratch. C IF (MXP .GE. 1016) WRITE (6, 15) MXP + 8 15 FORMAT (6X,'DOUBLE PRECISION MPDS'/ $ 6X,'COMMON /MPMCOM4/ MPDS(',I8,')') C C If any MP parameters have been defined, define a flag. C IF (MPA .GT. 0) WRITE (6, 16) 16 FORMAT (6X,'INTEGER MPPAR'/6X,'SAVE MPPAR'/6X,'DATA MPPAR /0/') C C This is the end of the declaration section. C WRITE (6, 17) 17 FORMAT ('C') C C Check if this is the main program. C IF (ISTP .EQ. 1) THEN C C Insert calls to set the precision level and scratch space. C WRITE (6, 18) MXP 18 FORMAT (6X,'CALL MPSETP (''NW'', ',I6,')') IF (MSS .NE. 0) WRITE (6, 19) MSS 19 FORMAT (6X,'CALL MPSETP (''IMS'', ',I8,')') C C Insert code to compute MPNWQ, MPNW4, MPL02, MPL10 and MPPIC. C WRITE (6, 20) MXP, MXP + 4 20 FORMAT ( $ 6X,'MPNWQ = ',I6/ $ 6X,'MPNW4 = ',I6/ $ 6X,'CALL MPDMC (2.D0, 0, MPM1)'/ $ 6X,'CALL MPLOG (MPM1, MPL02, MPL02)'/ $ 6X,'CALL MPDMC (10.D0, 0, MPM1)'/ $ 6X,'CALL MPLOG (MPM1, MPL02, MPL10)'/ $ 6X,'CALL MPPI (MPPIC)') ENDIF C C Set value for MPEPS if required. C C SGI f77 4.0 miscompiles this line. The next (equivalent) line is OK. C IF (KCON(2) .NE. 0) WRITE (6, 21) (EPS(I)(1:LEP(I)), I = 1, 2) C IF (KCON(2) .NE. 0) WRITE (6, 21) EPS(1)(1:LEP(1)), $ EPS(2)(1:LEP(2)) 21 FORMAT (6X,'CALL MPDMC (',A,', ',A,', MPEPS)') C C If MP parameters have been defined, insert code here. C IF (MPA .GT. 0) THEN WRITE (6, 22) 22 FORMAT (6X,'IF (MPPAR .EQ. 0) THEN') C 110 READ (12, '(A)', END = 120) LIN L1 = LNBLK (LIN) WRITE (6, '(A)') LIN(1:L1) GOTO 110 C 120 WRITE (6, 23) 23 FORMAT (6X,'MPPAR = 1'/6X,'ENDIF') ENDIF C WRITE (6, 24) 24 FORMAT ('CMP<') C RETURN END C SUBROUTINE INTRIN (LU, ITP1, L1, ARG1, NAR, ITAR, LAR, ARG, ITPX, $ LX, ARGX) C C This generates code for MP intrinsic functions. The function name is ARG1, C with type ITP1 and length L1. NAR is the number of arguments. The C argument list is input in ARG, with types in ITAR and lengths in LAR. C The result is placed in ARGX, with type in ITPX and length in LX. C LU is the unit number for output code. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*80 ARG1, ARG(MAR), ARGX, ARGZ CHARACTER*16 NAM DIMENSION ITAR(MAR), LAR(MAR) CHARACTER*4 GETMP, TMP1, TMP2, TMP3, TMP4, TMP5 C* C write (lu, *) 'enter intrin, nar, arg1 =', nar, C $ ' %'//arg1(1:l1)//'%' C write (lu, '(2i4,2x,a)') (i, itar(i), arg(i)(1:lar(i)), i = 1, nar) C* LL = MIN (L1, 16) NAM = ARG1(1:LL) IX = ITAB (0, 0, NAM) KTP = KTYP(IX) C C For functions with an argument-dependent result type, the type of the C result is the type of the first argument, except for ABS with a MPC C argument and NINT. C IF (KTP .NE. -1) THEN ITPX = KTP ELSEIF (IX .EQ. 11 .AND. ITAR(1) .EQ. 10) THEN ITPX = 9 ELSEIF (IX .EQ. 39) THEN ITPX = 8 ELSE ITPX = ITAR(1) ENDIF LX = 4 ARGX = GETMP (ITPX) C GOTO ( $ 100, 110, 120, 440, 130, 140, 150, 160, 450, 170, $ 180, 190, 200, 210, 220, 440, 450, 450, 230, 450, $ 450, 240, 450, 250, 260, 270, 280, 290, 300, 310, $ 320, 330, 340, 350, 360, 370, 380, 390, 400, 410, $ 420, 430, 460, 460) IX - 10 C C It is ABS. C 100 IF (NAR .NE. 1) GOTO 450 LA1 = LAR(1) IF (ITAR(1) .NE. 10) THEN WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4) 1 FORMAT (6X,'CALL MPEQ (',A,', ',A,')') WRITE (LU, 2) ARGX(1:4), ARGX(1:4) 2 FORMAT (6X,A,'(1) = ABS (',A,'(1))') ELSE TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) TMP4 = GETMP (9) WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2 3 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (LU, 4) TMP1, TMP1, TMP3 4 FORMAT (6X,'CALL MPMUL (',A,', ',A,', ',A,')') WRITE (LU, 4) TMP2, TMP2, TMP4 WRITE (LU, 5) TMP3, TMP4, TMP1 5 FORMAT (6X,'CALL MPADD (',A,', ',A,', ',A,')') WRITE (LU, 6) TMP1, ARGX(1:4) 6 FORMAT (6X,'CALL MPSQRT (',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) ENDIF GOTO 470 C C It is ACOS. C 110 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 7) TMP1 7 FORMAT (6X,'CALL MPDMC (1.D0, 0, ',A,')') WRITE (LU, 4) ARG(1)(1:LA1), ARG(1)(1:LA1), TMP2 WRITE (LU, 8) TMP1, TMP2, TMP3 8 FORMAT (6X,'CALL MPSUB (',A,', ',A,', ',A,')') WRITE (LU, 6) TMP3, TMP1 WRITE (LU, 9) ARG(1)(1:LA1), TMP1, ARGX(1:4) 9 FORMAT (6X,'CALL MPANG (',A,', ',A,', MPPIC, ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) GOTO 470 C C It is AINT. C 120 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 10) ARG(1)(1:LA1), ARGX(1:4), TMP1 10 FORMAT (6X,'CALL MPINFR (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) GOTO 470 C C It is ANINT. C 130 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 LA1 = LAR(1) WRITE (LU, 11) ARG(1)(1:LA1), ARGX(1:4) 11 FORMAT (6X,'CALL MPNINT (',A,', ',A,')') GOTO 470 C C It is ASIN. C 140 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (LU, 7) TMP1 WRITE (LU, 4) ARG(1)(1:LA1), ARG(1)(1:LA1), TMP2 WRITE (LU, 8) TMP1, TMP2, TMP3 WRITE (LU, 6) TMP3, TMP1 WRITE (LU, 9) TMP1, ARG(1)(1:LA1), ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) GOTO 470 C C It is ATAN. C 150 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 7) TMP1 WRITE (LU, 9) TMP1, ARG(1)(1:LA1), ARGX(1:4) CALL RLTMP (TMP1) GOTO 470 C C It is ATAN2. C 160 IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) LA2 = LAR(2) WRITE (LU, 9) ARG(2)(1:LA2), ARG(1)(1:LA1), ARGX(1:4) GOTO 470 C C It is CMPLX (convert MPC to CO). C 170 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450 WRITE (LU, 12) 12 FORMAT ('CMP*'/'CMP* Note: The result of CMPLX with an MP', $ ' argument has type CO.'/'CMP* If an MPC result is', $ ' required, use DPCMPL or an assignment statement.'/'CMP*') LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (3) TMP4 = GETMP (3) TMP5 = GETMP (1) WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 13) TMP1, TMP3, TMP5 13 FORMAT (6X,'CALL MPMDC (',A,', ',A,', ',A,')') WRITE (LU, 14) TMP3, TMP3, TMP5 14 FORMAT (6X,A,' = ',A,' * 2.D0 ** ',A) WRITE (LU, 13) TMP2, TMP4, TMP5 WRITE (LU, 14) TMP4, TMP4, TMP5 WRITE (LU, 15) ARGX(1:4), TMP3, TMP4 15 FORMAT (6X,A,' = DCMPLX (',A,', ',A,')') CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) GOTO 470 C C It is CONJG. C 180 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450 LA1 = LAR(1) WRITE (LU, 16) ARG(1)(1:LA1), ARGX(1:4) 16 FORMAT (6X,'CALL MPCEQ (MPNW4, ',A,', ',A,')') WRITE (LU, 17) ARGX(1:4), ARGX(1:4) 17 FORMAT (6X,A,'(MPNWQ+5) = - ',A,'(MPNWQ+5)') GOTO 470 C C It is COS. C 190 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 18) ARG(1)(1:LA1), ARGX(1:4), TMP1 18 FORMAT (6X,'CALL MPCSSN (',A,', MPPIC, ',A,', ',A,')') CALL RLTMP (TMP1) GOTO 470 C C It is COSH. C 200 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(3) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 19) ARG(1)(1:LA1), ARGX(1:4), TMP1 19 FORMAT (6X,'CALL MPCSSH (',A,', MPL02, ',A,', ',A,')') CALL RLTMP (TMP1) GOTO 470 C C It is DBLE (convert MPI or MPR to DP). C 210 IF (NAR .NE. 1) GOTO 450 WRITE (LU, 20) 20 FORMAT ('CMP*'/'CMP* Note: The result of DBLE with an MP', $ ' argument has type DP.'/'CMP* If an MPR result is', $ ' required, use DPREAL or an assignment statement.'/'CMP*') LA1 = LAR(1) TMP1 = GETMP (3) TMP2 = GETMP (1) WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 14) ARGX(1:4), TMP1, TMP2 CALL RLTMP (TMP1) CALL RLTMP (TMP2) GOTO 470 C C It is DCMPLX (convert MPC to DC). C 220 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450 WRITE (LU, 21) 21 FORMAT ('CMP*'/'CMP* Note: The result of DCMPLX with an MP', $ ' argument has type DC.'/'CMP* If an MPC result is', $ ' required, use DPCMPL or an assignment statement.'/'CMP*') LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) TMP3 = GETMP (3) TMP4 = GETMP (3) TMP5 = GETMP (1) WRITE (LU, 3) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 13) TMP1, TMP3, TMP5 WRITE (LU, 14) TMP3, TMP3, TMP5 WRITE (LU, 13) TMP2, TMP4, TMP5 WRITE (LU, 14) TMP4, TMP4, TMP5 WRITE (LU, 15) ARGX(1:4), TMP3, TMP4 CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) CALL RLTMP (TMP4) CALL RLTMP (TMP5) GOTO 470 C C It is EXP. C 230 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(3) = 1 LA1 = LAR(1) WRITE (LU, 22) ARG(1)(1:LA1), ARGX(1:4) 22 FORMAT (6X,'CALL MPEXP (',A,', MPL02, ',A,')') GOTO 470 C C It is INT (convert MPI or MPR to IN). C 240 IF (NAR .NE. 1) GOTO 450 WRITE (LU, 23) 23 FORMAT ('CMP*'/'CMP* Note: The result of INT with an MP', $ ' argument has type IN.'/'CMP* If an MPI result is', $ ' required, use MPINT or an assignment statement.'/'CMP*') LA1 = LAR(1) TMP1 = GETMP (3) TMP2 = GETMP (1) WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 14) ARGX(1:4), TMP1, TMP2 CALL RLTMP (TMP1) CALL RLTMP (TMP2) GOTO 470 C C It is LOG. C 250 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(3) = 1 LA1 = LAR(1) WRITE (LU, 24) ARG(1)(1:LA1), ARGX(1:4) 24 FORMAT (6X,'CALL MPLOG (',A,', MPL02, ',A,')') GOTO 470 C C It is LOG10. C 260 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(4) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 24) ARG(1)(1:LA1), TMP1 WRITE (LU, 25) TMP1, 'MPL10', ARGX(1:4) 25 FORMAT (6X,'CALL MPDIV (',A,', ',A,', ',A,')') CALL RLTMP (TMP1) GOTO 470 C C It is MAX. C 270 IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10) $ GOTO 450 LA1 = LAR(1) LA2 = LAR(2) TMP1 = GETMP (1) WRITE (LU, 26) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1 26 FORMAT (6X,'CALL MPCPR (',A,', ',A,', ',A,')') WRITE (LU, 27) TMP1, ARG(1)(1:LA1), ARGX(1:4), ARG(2)(1:LA2), $ ARGX(1:4) 27 FORMAT (6X,'IF (',A,' .GE. 0) THEN'/ $ 8X,'CALL MPEQ (',A,', ',A,')'/6X,'ELSE'/ $ 8X,'CALL MPEQ (',A,', ',A,')'/6X,'ENDIF') CALL RLTMP (TMP1) GOTO 470 C C It is MIN. C 280 IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10) $ GOTO 450 LA1 = LAR(1) LA2 = LAR(2) TMP1 = GETMP (1) WRITE (LU, 26) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1 WRITE (LU, 27) TMP1, ARG(2)(1:LA2), ARGX(1:4), ARG(1)(1:LA1), $ ARGX(1:4) CALL RLTMP (TMP1) GOTO 470 C C It is MOD. C 290 IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10) $ GOTO 450 LA1 = LAR(1) LA2 = LAR(2) TMP1 = GETMP (9) TMP2 = GETMP (8) TMP3 = GETMP (9) WRITE (LU, 25) ARG(1)(1:LA1), ARG(2)(1:LA2), TMP1 WRITE (LU, 10) TMP1, TMP2, TMP3 WRITE (LU, 4) ARG(2)(1:LA2), TMP2, TMP1 WRITE (LU, 8) ARG(1)(1:LA1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) CALL RLTMP (TMP3) GOTO 470 C C It is NINT. C 300 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 LA1 = LAR(1) WRITE (LU, 11) ARG(1)(1:LA1), ARGX(1:4) GOTO 470 C C It is REAL (convert MPI or MPR to SP). C 310 IF (NAR .NE. 1) GOTO 450 WRITE (LU, 28) 28 FORMAT ('CMP*'/'CMP* Note: The result of REAL with an MP', $ ' argument has type SP.'/'CMP* If an MPR result is', $ ' required, use DPREAL or an assignment statement.'/'CMP*') LA1 = LAR(1) TMP1 = GETMP (3) TMP2 = GETMP (1) WRITE (LU, 13) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 14) ARGX(1:4), TMP1, TMP2 CALL RLTMP (TMP1) CALL RLTMP (TMP2) GOTO 470 C C It is SIGN. C 320 IF (NAR .NE. 2 .OR. ITAR(1) .NE. ITAR(2) .OR. ITAR(1) .EQ. 10) $ GOTO 450 LA1 = LAR(1) LA2 = LAR(2) TMP1 = GETMP (9) WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4) WRITE (LU, 1) ARG(2)(1:LA2), TMP1 WRITE (LU, 29) TMP1, ARGX(1:4), ARGX(1:4), ARGX(1:4), ARGX(1:4) 29 FORMAT (6X,'IF (',A,'(1) .GE. 0.) THEN'/ $ 6X,A,'(1) = ABS (',A,'(1))'/6X,'ELSE'/ $ 6X,A,'(1) = - ABS (',A,'(1))'/6X,'ENDIF') CALL RLTMP (TMP1) GOTO 470 C C It is SIN. C 330 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 18) ARG(1)(1:LA1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) GOTO 470 C C It is SINH. C 340 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(3) = 1 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 19) ARG(1)(1:LA1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) GOTO 470 C C It is SQRT. C 350 IF (NAR .NE. 1 .OR. ITAR(1) .EQ. 8) GOTO 450 LA1 = LAR(1) IF (ITAR(1) .EQ. 9) THEN WRITE (LU, 6) ARG(1)(1:LA1), ARGX(1:4) ELSEIF (ITAR(1) .EQ. 10) THEN WRITE (LU, 30) ARG(1)(1:LA1), ARGX(1:4) 30 FORMAT (6X,'CALL MPCSQR (MPNW4, ',A,', ',A,')') ENDIF GOTO 470 C C It is TAN. C 360 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(5) = 1 LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 18) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 25) TMP2, TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) GOTO 470 C C It is TANH. C 370 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 KCON(3) = 1 LA1 = LAR(1) TMP1 = GETMP (9) TMP2 = GETMP (9) WRITE (LU, 19) ARG(1)(1:LA1), TMP1, TMP2 WRITE (LU, 25) TMP2, TMP1, ARGX(1:4) CALL RLTMP (TMP1) CALL RLTMP (TMP2) GOTO 470 C C It is MPINT. C 380 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 9) GOTO 450 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 10) ARG(1)(1:LA1), ARGX(1:4), TMP1 CALL RLTMP (TMP1) GOTO 470 C C It is DPCMPL. C 390 IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 9) GOTO 450 LA1 = LAR(1) LA2 = LAR(2) WRITE (LU, 31) ARG(1)(1:LA1), ARG(2)(1:LA2), ARGX(1:4) 31 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') GOTO 470 C C It is DPIMAG. C 400 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450 LA1 = LAR(1) TMP1 = GETMP (9) WRITE (LU, 3) ARG(1)(1:LA1), TMP1, ARGX(1:4) CALL RLTMP (TMP1) GOTO 470 C C It is DPREAL. C 410 IF (NAR .NE. 1 .OR. ITAR(1) .NE. 10) GOTO 450 LA1 = LAR(1) WRITE (LU, 1) ARG(1)(1:LA1), ARGX(1:4) GOTO 470 C C It is DPNRT. C 420 IF (NAR .NE. 2 .OR. ITAR(1) .NE. 9 .OR. ITAR(2) .NE. 1) GOTO 450 LA1 = LAR(1) LA2 = LAR(2) WRITE (LU, 32) ARG(1)(1:LA1), ARG(2)(1:LA2), ARGX(1:4) 32 FORMAT (6X,'CALL MPNRT (',A,', ',A,', ',A,')') GOTO 470 C C It is DPRAND. C 430 IF (NAR .NE. 0) GOTO 450 WRITE (LU, 33) ARGX(1:4) 33 FORMAT (6X,'CALL MPRAND (',A,')') GOTO 470 C 440 CALL ERRMES (64, 0) WRITE (6, 34) ARG1(1:L1) 34 FORMAT ('This intrinsic function is not defined with this MP', $ ' argument type: ',A) CALL ABRT C 450 CALL ERRMES (65, 0) WRITE (6, 35) ARG1(1:L1) 35 FORMAT ('This intrinsic function has an improper argument list: ', $ A) CALL ABRT C 460 CALL ERRMES (66, 0) WRITE (6, 36) ARG1(1:L1) 36 FORMAT ('This subroutine name may not be used as a function: ',A) CALL ABRT C 470 CONTINUE C* C write (lu, *) 'exit intrin itpx, argx =', itpx, C $ ' %'//argx(1:lx)//'%' C* RETURN END C FUNCTION IPFSB (K1, LN) C C This checks to see if the statement is a program, subroutine, function C or block data statement. K1 and LN are the indices of the first and last C non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*16 LINQ, NAM, UCASE C J1 = K1 LQ = MIN (J1 + 15, LN) LINQ = UCASE (LINE(J1:LQ)) IF (LINQ(1:7) .EQ. 'PROGRAM') THEN IF (IEX .NE. 0) GOTO 100 ISTP = 1 IPFSB = 1 J1 = NBLK (J1 + 7, LN, LINE) FNAM = LINE(J1:LN) LSAR = 0 CALL OUTLIN (1, LN, LINE) ELSEIF (LINQ(1:10) .EQ. 'SUBROUTINE') THEN IF (IEX .NE. 0) GOTO 100 ISTP = 2 IPFSB = 1 J1 = NBLK (J1 + 10, LN, LINE) J3 = INDX (J1, LN, '(', LINE) IF (J3 .NE. 0) THEN J2 = J3 - 1 ELSE J2 = LN ENDIF FNAM = LINE(J1:J2) IF (J3 .NE. 0) THEN LSAR = LN - J3 - 1 SARG(1:LSAR) = LINE(J3+1:LN-1) ELSE LSAR = 0 SARG(1:1) = ' ' ENDIF CALL OUTLIN (1, LN, LINE) ELSEIF (LINQ(1:8) .EQ. 'FUNCTION') THEN IF (IEX .NE. 0) GOTO 100 ISTP = 3 JS = J1 J1 = NBLK (J1 + 8, LN, LINE) J3 = INDX (J1, LN, '(', LINE) IF (J3 .EQ. 0) CALL ERRMES (67, 1) J2 = J3 - 1 FNAM = LINE(J1:J2) IX = ITAB (0, 0, FNAM) LSAR = LN - J3 - 1 SARG(1:LSAR) = LINE(J3+1:LN-1) C C If the function name is MP, then change to subroutine statement. C IF (IX .GT. MINT .AND. KTYP(IX) .GE. 8) THEN KDIM(IX) = -2 CALL OUTLIN (2, LN, LINE) LINA(1:JS-1) = LINE(1:JS-1) LINA(JS:JS+9) = 'SUBROUTINE' LINA(JS+10:LN+1) = LINE(JS+8:LN-1) LINA(LN+2:LN+9) = ', MPFVX)' NAM = 'MPFVX' IX = ITAB (2, KTYP(IX), NAM) LA = LN + 9 CALL OUTLIN (1, LA, LINA) WRITE (11, 1) 1 FORMAT ('CMP<') ELSE CALL OUTLIN (1, LN, LINE) ENDIF IPFSB = 1 ELSEIF (LINQ(1:10) .EQ. 'BLOCK DATA') THEN IF (IEX .NE. 0) GOTO 100 ISTP = 4 IPFSB = 1 CALL OUTLIN (1, LN, LINE) ELSE IPFSB = 0 ENDIF GOTO 120 C 100 CALL ERRMES (68, 0) WRITE (6, 2) 2 FORMAT ('A declarative statement may not appear after an', $ ' executable statement.') CALL ABRT C 110 CALL ERRMES (69, 0) WRITE (6, 3) 3 FORMAT ('Too many program units in this file.') CALL ABRT C 120 RETURN END C FUNCTION ISCAN (K1, LN, LINA) C C This scans LINE between positions K1 and LN for variable names and C enters new ones into the table. The result is 1 if a MP constant or C special constant name is found, 2 if a MP variable is found, and 0 C otherwise. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*16 NAM CHARACTER*1 CJ C J1 = K1 ISCAN = 0 C C Extract the next character from the line. C 100 IF (J1 .GT. LN) GOTO 130 J1 = NBLK (J1, LN, LINA) CJ = LINA(J1:J1) C C Check if it is the start of a numeric constant. C IS1 = INDEX (DIG, CJ) IF ((CJ .EQ. '-' .OR. CJ .EQ. '.') .AND. J1 .LT. LN) THEN J2 = NBLK (J1 + 1, LN, LINA) IS2 = INDEX (DIG, LINA(J2:J2)) ELSE IS2 = 0 ENDIF C IF (IS1 .NE. 0 .OR. IS2 .NE. 0) THEN ITP = NUMCON (J1, J2, LN, LINA) J1 = J2 + 1 GOTO 100 C C Check if it the start of a name. C ELSEIF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN C DO 110 J = J1, LN CJ = LINA(J:J) IF (INDEX (DEL, CJ) .NE. 0) GOTO 120 110 CONTINUE C J = LN + 1 120 I2 = J - 1 NAM = LINA(J1:I2) IX = ITAB (1, 0, NAM) IF (IX .EQ. 0) THEN J1 = I2 + 1 GOTO 100 ENDIF ITP = KTYP(IX) IF (ITP .LT. 8) KDEC(IX) = 1 C C Check if the variable is a special constant. C IF (IX .GE. 1 .AND. IX .LE. 5) THEN ISCAN = MAX (ISCAN, 1) C C Check if the variable is MP. C ELSEIF (ITP .GE. 8) THEN ISCAN = 2 ENDIF J1 = I2 + 1 GOTO 100 C C Check if it is the start of a logical constant. C ELSEIF (CJ .EQ. '.') THEN I1 = INDX (J1 + 1, LN, '.', LINA) IF (I1 .EQ. 0) CALL ERRMES (70, 1) J1 = I1 + 1 GOTO 100 C C Check if it is the start of a character constant. C ELSEIF (CJ .EQ. '"') THEN I1 = INDX (J1 + 1, LN, '"', LINA) IF (I1 .EQ. 0) CALL ERRMES (71, 1) J1 = I1 + 1 GOTO 100 ELSEIF (CJ .EQ. "'") THEN I1 = INDX (J1 + 1, LN, "'", LINA) IF (I1 .EQ. 0) CALL ERRMES (72, 1) J1 = I1 + 1 GOTO 100 ENDIF C C Check if it is one of the miscellaneous symbols. C I1 = INDEX (DEL, CJ) IF (I1 .EQ. 0) THEN CALL ERRMES (73, 0) WRITE (6, 1) CJ 1 FORMAT ('Illegal character: ',A) CALL ABRT ENDIF J1 = J1 + 1 GOTO 100 C 130 CONTINUE RETURN END C FUNCTION ITAB (IC, ITP, NAM) C C This routine searches for NAM in the variable table and returns its index C if found. If it is not found, the action depends on the value of IC as C follows: C IC C 0 Name is not entered in table and zero is returned. C 1 New names are entered in table. Four letter names starting with DP C or MP are NOT allowed. The entry in KTYP is set to ITP if ITP is C nonzero, otherwise to the implicit type. C 2 New names are entered in table. Four letter names starting with DP C or MP are allowed. The entry in KTYP is set to ITP if ITP is C nonzero, otherwise to the implicit type. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*16 NAM, NAMX, UCASE CHARACTER*1 CJ C C Set NAMX = NAM with upper case alphabetics and check table. C NAMX = UCASE (NAM) C DO 100 I = 1, NVAR IF (VAR(I) .EQ. NAMX) THEN ITAB = I GOTO 120 ENDIF 100 CONTINUE C C NAMX is not in table. C IF (IC .EQ. 0) THEN ITAB = 0 GOTO 120 ENDIF C C Check if NAMX is a common Fortran keyword -- if so, don't enter in table. C DO 110 I = 1, NKY IF (NAMX .EQ. KEYW(I)) THEN ITAB = 0 GOTO 120 ENDIF 110 CONTINUE C C Check if it is a four-letter name starting with DP or MP. C L1 = LNBLK (NAMX) IF (IC .EQ. 1 .AND. L1 .EQ. 4) THEN IF (NAMX(1:2) .EQ. 'DP' .OR. NAMX(1:2) .EQ. 'MP') THEN CALL ERRMES (74, 0) WRITE (6, 1) 1 FORMAT ('Four-letter names starting with DP or MP are not', $ ' allowed.') CALL ABRT ENDIF ENDIF C C Add NAMX to table. C NVAR = NVAR + 1 IF (NVAR .GT. MVAR) THEN CALL ERRMES (75, 0) WRITE (6, 2) 2 FORMAT ('Subprogram has too many variables.') CALL ABRT ENDIF C VAR(NVAR) = NAMX KDEC(NVAR) = 0 KDIM(NVAR) = 0 LVAR(NVAR) = L1 C C If ITP is greater than zero, set the type of the new variable to ITP. C If ITP is zero, set the type to the implicit type. The type is stored C in the array KTYP. Whether explicit or implicit is stored in MPLC. C IF (ITP .GT. 0) THEN KTYP(NVAR) = ITP MPLC(NVAR) = 0 ELSE CJ = NAMX(1:1) I1 = INDEX (ALPU, CJ) IF (I1 .EQ. 0) CALL ERRMES (76, 1) KTYP(NVAR) = IMPL(I1) MPLC(NVAR) = 1 ENDIF ITAB = NVAR C 120 RETURN END C FUNCTION LNBLK (LIN) CHARACTER*(*) LIN C C This finds the index of the last non-blank character in LIN. C LN = LEN (LIN) C DO 100 I = LN, 1, -1 IF (LIN(I:I) .NE. ' ') GOTO 110 100 CONTINUE C I = 0 110 LNBLK = I C RETURN END C FUNCTION MATCH (IC, K1, LA, LINA) C C This finds the location (up to LA) in LINA of the right parenthesis that C matches the left parenthesis at location K1 - 1. If IC is nonzero, a comma C will also will be accepted as a terminator. Parentheses or commas in C character constants are ignored. C CHARACTER*1600 LINA CHARACTER*1 CJ C J1 = K1 IP = 0 MATCH = 0 C 100 IF (J1 .GT. LA) GOTO 110 J1 = NBLK (J1, LA, LINA) IF (J1 .EQ. 0) GOTO 110 CJ = LINA(J1:J1) IF (CJ .EQ. ')' .OR. (CJ .EQ. ',' .AND. IC .NE. 0 .AND. $ IP .EQ. 0)) THEN IF (IP .EQ. 0) THEN MATCH = J1 GOTO 110 ELSE IP = IP - 1 J1 = J1 + 1 GOTO 100 ENDIF ELSEIF (CJ .EQ. '(') THEN IP = IP + 1 J1 = J1 + 1 GOTO 100 ELSEIF (CJ .EQ. '"') THEN J1 = INDX (J1 + 1, LA, '"', LINA) IF (J1 .EQ. 0) CALL ERRMES (77, 1) J1 = J1 + 1 GOTO 100 ELSEIF (CJ .EQ. "'") THEN J1 = INDX (J1 + 1, LA, "'", LINA) IF (J1 .EQ. 0) CALL ERRMES (78, 1) J1 = J1 + 1 GOTO 100 ELSE J1 = J1 + 1 GOTO 100 ENDIF C 110 CONTINUE C RETURN END C SUBROUTINE MPDEC (LN) C C This checks to see if a comment is a MP directive. LN is the index of C the last non-blank character. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ C> Set CON to be the Log_10 BDX, where BDX is the radix in MPFUN. C For IEEE and other systems for which BDX = 2^24, CON = 7.224719896D0. C For Cray systems and others for which BDX = 2^22, CON = 6.622659905D0. C DOUBLE PRECISION CON, CL2, T1 PARAMETER (CON = 7.224719896D0, RLT = 3.321928095D0) CHARACTER*16 LINQ, NUMX, NUMY, UCASE C J1 = NBLK (5, LN, LINE) C LQ = MIN (J1 + 15, LN) LINQ = UCASE (LINE(J1:LQ)) IF (LINQ(1:15) .EQ. 'PRECISION LEVEL') THEN IF (MXP .NE. 0 .OR. ISTP .NE. 0) GOTO 110 IF (IEX .NE. 0) GOTO 140 NUMX = LINE(J1+15:LN) READ (NUMX, '(BN,I16)', ERR = 120) K IF (K .LE. 0) GOTO 120 MXP = (K + 7) / CON MPP = CON * MXP T1 = RLT * (7 - K) N1 = T1 - 1.D0 T1 = 2.D0 ** (T1 - N1) WRITE (NUMY, '(1PD16.8)') T1 I1 = NBLK (1, 16, NUMY) LEP(1) = 17 - I1 EPS(1) = NUMY(I1:16) WRITE (NUMY, '(I10)') N1 I1 = NBLK (1, 10, NUMY) LEP(2) = 11 - I1 EPS(2) = NUMY(I1:10) ELSEIF (LINQ(1:13) .EQ. 'SCRATCH SPACE') THEN IF (MXP .EQ. 0) GOTO 100 IF (MSS .NE. 0 .OR. ISTP .NE. 0) GOTO 110 IF (IEX .NE. 0) GOTO 140 NUMX = LINE(J1+13:LN) READ (NUMX , '(BN,I16)', ERR = 120) K IF (K .LE. 0) GOTO 120 MSS = K ELSEIF (LINQ(1:8) .EQ. 'IMPLICIT') THEN IF (MXP .EQ. 0) GOTO 100 IF (ISTP .EQ. 0) GOTO 110 IF (IEX .NE. 0) GOTO 140 K1 = NBLK (J1 + 8, LN, LINE) CALL IMPLIC (K1, LN) MPT = 1 ELSEIF (LINQ(1:10) .EQ. 'TYPE ERROR') THEN IF (MXP .EQ. 0) GOTO 100 IF (IEX .NE. 0) GOTO 140 J1 = NBLK (J1 + 10, LN, LINE) LQ = MIN (J1 + 15, LN) LINQ = UCASE (LINE(J1:LQ)) IF (LINQ(1:2) .EQ. 'ON') THEN ITE = 1 ELSEIF (LINQ(1:3) .EQ. 'OFF') THEN ITE = 0 ELSE CALL ERRMES (79, 0) ENDIF ELSEIF (LINQ(1:10) .EQ. 'MIXED MODE') THEN IF (MXP .EQ. 0) GOTO 100 IF (IEX .NE. 0) GOTO 140 J1 = NBLK (J1 + 10, LN, LINE) LQ = MIN (J1 + 15, LN) LINQ = UCASE (LINE(J1:LQ)) IF (LINQ(1:4) .EQ. 'SAFE') THEN IMM = 1 ELSEIF (LINQ(1:4) .EQ. 'FAST') THEN IMM = 0 ELSE CALL ERRMES (80, 0) ENDIF ELSEIF (LINQ(1:16) .EQ. 'OUTPUT PRECISION') THEN IF (MXP .EQ. 0) GOTO 100 IF (IEX .NE. 0) GOTO 140 NUMX = LINE(J1+16:LN) READ (NUMX, '(BN,I16)', ERR = 120) K IF (K .LE. 0) GOTO 120 MPP = K ELSEIF (LINQ(1:7) .EQ. 'EPSILON') THEN IF (MXP .EQ. 0) GOTO 100 IF (IEX .NE. 0) GOTO 140 K1 = NBLK (J1 + 7, LN, LINE) I1 = MAX (INDX (K1, LN, 'E', LINE), INDX (K1, LN, 'e', LINE)) IF (I1 .EQ. 0) CALL ERRMES (81, 1) NUMX = LINE(K1:I1-1) READ (NUMX, '(F16.0)') T1 NUMX = LINE(I1+1:LN) READ (NUMX, '(BN,I16)') N1 IF (T1 .LE. 0 .OR. N1 .GE. 0) CALL ERRMES (82, 1) T1 = RLT * (N1 + LOG10 (T1)) N1 = T1 - 1.D0 T1 = 2.D0 ** (T1 - N1) WRITE (NUMY, '(1PD16.8)') T1 I1 = NBLK (1, 16, NUMY) LEP(1) = 17 - I1 EPS(1) = NUMY(I1:16) WRITE (NUMY, '(I10)') N1 I1 = NBLK (1, 10, NUMY) LEP(2) = 11 - I1 EPS(2) = NUMY(I1:10) ELSE C C Check for MP type declarative. C IT = NTYPE (J1, LN) IF (IT .GE. 8) THEN IF (MXP .EQ. 0) GOTO 100 IF (IEX .NE. 0) GOTO 140 CALL TYPE (IT, J1, LN) MPT = 1 IF (IT .EQ. 10) KCON(1) = 1 ELSE GOTO 130 ENDIF ENDIF GOTO 150 C 100 CALL ERRMES (83, 0) WRITE (6, 1) 1 FORMAT ('Precision level has not yet been declared.') CALL ABRT C 110 CALL ERRMES (84, 0) WRITE (6, 2) 2 FORMAT ('Improper placement of MP directive.') CALL ABRT C 120 CALL ERRMES (85, 0) WRITE (6, 3) 3 FORMAT ('Improper integer constant.') CALL ABRT C 130 CALL ERRMES (86, 0) WRITE (6, 4) 4 FORMAT ('Unrecognized CMP+ directive.') CALL ABRT C 140 CALL ERRMES (87, 0) WRITE (6, 5) 5 FORMAT ('A declarative statement may not appear after an', $ ' executable statement.') CALL ABRT C 150 RETURN END C FUNCTION NBLK (K1, K2, LIN) C C This finds the index of the first non-blank character in LIN between C positions K1 and K2. LIN may be of any character type. C CHARACTER*(*) LIN C DO 100 I = K1, K2 IF (LIN(I:I) .NE. ' ') GOTO 110 100 CONTINUE C I = 0 110 NBLK = I C RETURN END C FUNCTION NTYPE (K1, K2) C C Identifies type declarations in type statements or implicit statements C and repositions pointer one past end of declarative. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*16 LINQ, UCASE C LQ = MIN (K1 + 15, K2) LINQ = UCASE (LINE(K1:LQ)) IF (LINQ(1:7) .EQ. 'INTEGER') THEN NTYPE = 1 K1 = NBLK (K1 + 7, K2, LINE) IF (LINE(K1:K1) .EQ. '*') K1 = 1 + NBLK (K1 + 1, K2, LINE) ELSEIF (LINQ(1:5) .EQ. 'REAL ' .OR. LINQ(1:5) .EQ. 'REAL*') THEN NTYPE = 2 K1 = NBLK (K1 + 4, K2, LINE) IF (LINE(K1:K1) .EQ. '*') THEN K1 = NBLK (K1 + 1, K2, LINE) IF (LINE(K1:K1) .EQ. '8') NTYPE = 3 K1 = K1 + 1 ENDIF ELSEIF (LINQ(1:6) .EQ. 'DOUBLE') THEN NTYPE = 3 K1 = NBLK (K1 + 6, K2, LINE) LQ = MIN (K1 + 15, K2) LINQ = UCASE (LINE(K1:LQ)) IF (LINQ(1:9) .EQ. 'PRECISION') THEN K1 = K1 + 9 ELSEIF (LINQ(1:7) .EQ. 'COMPLEX') THEN NTYPE = 5 K1 = K1 + 7 ENDIF ELSEIF (LINQ(1:7) .EQ. 'COMPLEX') THEN NTYPE = 4 K1 = NBLK (K1 + 7, K2, LINE) IF (LINE(K1:K1) .EQ. '*') THEN K1 = NBLK (K1 + 1, K2, LINE) IF (LINE(K1:K1+1) .EQ. '16') THEN NTYPE = 5 K1 = K1 + 2 ELSE K1 = K1 + 1 ENDIF ENDIF ELSEIF (LINQ(1:9) .EQ. 'CHARACTER') THEN NTYPE = 6 K1 = NBLK (K1 + 9, K2, LINE) IF (LINE(K1:K1) .EQ. '*') THEN K1 = NBLK (K1 + 1, K2, LINE) J3 = INDX (K1, K2, ' ', LINE) IF (J3 .NE. 0) THEN K1 = J3 ELSE K1 = K2 + 1 ENDIF ENDIF ELSEIF (LINQ(1:7) .EQ. 'LOGICAL') THEN NTYPE = 7 K1 = NBLK (K1 + 7, K2, LINE) IF (LINE(K1:K1) .EQ. '*') K1 = 1 + NBLK (K1 + 1, K2, LINE) ELSEIF (LINQ(1:14) .EQ. 'MULTIP INTEGER') THEN NTYPE = 8 K1 = NBLK (K1 + 14, K2, LINE) ELSEIF (LINQ(1:11) .EQ. 'MULTIP REAL') THEN NTYPE = 9 K1 = NBLK (K1 + 11, K2, LINE) ELSEIF (LINQ(1:14) .EQ. 'MULTIP COMPLEX') THEN NTYPE = 10 K1 = NBLK (K1 + 14, K2, LINE) ELSE NTYPE = 0 ENDIF C RETURN END C FUNCTION NUMCON (K1, K2, LA, LINA) C C This parses numeric constants, returning the type of the constant. C K1 is the index of the start of the constant, and K2 is the index of C the end (an output value). LA is the index of the last non-blank C character in LINA. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*1 CJ C C IB = 1 if the previous character was a blank, 0 otherwise. C ID = 1 if a digit has occurred, 0 otherwise. Reset to 0 after D or E. C IP = 1 if a period has occurred, 0 otherwise. C IS = 1 if a sign has occurred, 0 otherwise. Reset to 0 after D or E. C IT = The type number of the constant (1, 2, 3 or 9). C IX = 1 if a D or E has occurred, 0 otherwise. C IB = 0 ID = 0 IP = 0 IS = 0 IT = 1 IX = 0 C DO 100 J = K1, LA CJ = LINA(J:J) IF (INDEX (DIG, CJ) .NE. 0) THEN ID = 1 GOTO 100 ELSEIF (CJ .EQ. '.') THEN IF (IP .NE. 0 .OR. IX .NE. 0 .OR. J .EQ. IB + 1) GOTO 110 IP = 1 IT = 2 GOTO 100 ELSEIF (CJ .EQ. 'D' .OR. CJ .EQ. 'd') THEN IF (IX .EQ. 1) CALL ERRMES (88, 1) ID = 0 IS = 0 IT = 3 IX = 1 GOTO 100 ELSEIF (CJ .EQ. 'E' .OR. CJ .EQ. 'e') THEN IF (IX .EQ. 1) CALL ERRMES (89, 1) ID = 0 IS = 0 IT = 2 IX = 1 GOTO 100 ELSEIF (CJ .EQ. '+' .OR. CJ .EQ. '-') THEN IF (ID .NE. 0 .OR. IS .NE. 0) GOTO 110 IF (IP .NE. 0 .AND. IX .EQ. 0) CALL ERRMES (90, 1) IS = 1 GOTO 100 ELSEIF (CJ .EQ. ' ') THEN IB = J GOTO 100 ELSE GOTO 110 ENDIF 100 CONTINUE C J = LA + 1 C C Numeric constant has been parsed. Trim any trailing blanks. C 110 K2 = J - 1 120 IF (K2 .GE. K1 .AND. LINA(K2:K2) .EQ. ' ') THEN K2 = K2 - 1 GOTO 120 ENDIF NUMCON = IT C RETURN END C SUBROUTINE OUTLIN (IC, LA, LINA) C C This outputs Fortran statements. If IC is 0, LINA is a comment line up C to 80 characters long. If IC is 1, LINA is a possibly multiline Fortran C statement. If IC is 2, LINA is a possibly multiline Fortran statement that C will be output with 'CMP>' at the start of each line. If IC is 3, LINA is C a possibly multiline Fortran statement that is to be output on unit 8 C instead of 7. C CHARACTER*1600 LINA C IF (IC .EQ. 0) THEN I1 = MAX (LA, 1) WRITE (11, 1) LINA(1:I1) 1 FORMAT (A) ELSEIF (IC .EQ. 1) THEN I1 = MIN (LA, 72) WRITE (11, 1) LINA(1:I1) C DO 100 I = 73, LA, 66 I1 = MIN (I + 65, LA) WRITE (11, 2) LINA(I:I1) 2 FORMAT (5X,'$',A) 100 CONTINUE C ELSEIF (IC .EQ. 2) THEN I1 = MIN (LA, 72) WRITE (11, 3) LINA(7:I1) 3 FORMAT ('CMP> ',A) C DO 110 I = 73, LA, 66 I1 = MIN (I + 65, LA) WRITE (11, 4) LINA(I:I1) 4 FORMAT ('CMP> $',A) 110 CONTINUE C ELSEIF (IC .EQ. 3) THEN I1 = MIN (LA, 72) WRITE (12, 1) LINA(1:I1) C DO 120 I = 73, LA, 66 I1 = MIN (I + 65, LA) WRITE (12, 2) LINA(I:I1) 120 CONTINUE C ENDIF C RETURN END C SUBROUTINE PARAM (K1, LN) C C This processes parameter statements. K1 is the index of the first C character after 'PARAMETER'. LN is the index of the last non-blank C character. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*80 ARG(MAR), ARGX DIMENSION ITAR(MAR), LAR(MAR) C C Use FIXSUB to change names of special constants. C K2 = LN CALL FIXSUB (K1, K2, LN) C C Use ARLIST to process each separate expression. C J1 = NBLK (K1, LN, LINE) IF (LINE(J1:J1) .NE. '(' .OR. LINE(LN:LN) .NE. ')') $ CALL ERRMES (91, 1) LA = LN - J1 - 1 LINA(1:LA) = LINE(J1+1:LN-1) CALL ARLIST (12, LA, LINA, NAR, ITAR, LAR, ARG) IF (NAR .EQ. 0) CALL ERRMES (92, 1) MPA = MPA + NAR C C Make sure that all expressions were assignments. C DO 100 I = 1, NAR IF (LAR(I) .NE. 0) CALL ERRMES (93, 1) 100 CONTINUE C RETURN END C SUBROUTINE RDWR (IRW, K1, K2, LN) C C This processes read and write statements, depending on whether IRW is C 1 or 2. K1 and K2 and the indices of the parentheses. LN is the index C of the last non-blank character. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA CHARACTER*80 ARG(MAR), ARGK CHARACTER*16 UNIT, NAM CHARACTER*8 NUMX, NUMY DIMENSION ITAR(MAR), LAR(MAR) CHARACTER*4 TMP1, TMP2, TMP3, GETMP C C Place the output precision parameter into a character variable. C WRITE (NUMY, '(I8)') MPP I1 = NBLK (1, 8, NUMY) LX = 9 - I1 NUMX = NUMY(I1:8) C C Determine unit number. C I1 = INDX (K1, LN, ',', LINE) IF (I1 .NE. 0 .AND. I1 .LT. K2) THEN I2 = I1 ELSE I2 = K2 ENDIF LUN = I2 - K1 - 1 UNIT(1:LUN) = LINE(K1+1:I2-1) C C Check if there is a * for the format. C IF (I2 .LT. K2) THEN I2 = NBLK (I2 + 1, K2, LINE) IF (LINE(I2:K2-1) .NE. '*') THEN CALL ERRMES (94, 0) WRITE (6, 1) 1 FORMAT ('This form of read/write statement is not allowed', $ ' with MP variables.') CALL ABRT ENDIF ELSE C C There is no star or format number -- this is a binary I/O statement. C Check to make sure there are no parentheses. C I1 = INDX (K2 + 1, LN, '(', LINE) IF (I1 .NE. 0) THEN CALL ERRMES (95, 0) WRITE (6, 2) 2 FORMAT ('Only entire arrays may be output with binary MP', $ ' I/O.') CALL ABRT ENDIF CALL OUTLIN (1, LN, LINE) GOTO 120 ENDIF C C Form a list of the arguments. C J1 = NBLK (K2 + 1, LN, LINE) LA = LN - J1 + 1 LINA(1:LA) = LINE(J1:LN) CALL ARLIST (11, LA, LINA, NAR, ITAR, LAR, ARG) C C Process the statement. C DO 100 K = 1, NAR ARGK = ARG(K) LK = LAR(K) ITK = ITAR(K) C C Set NAM to be the argument without subscripts. C I1 = INDEX (ARGK(1:LK), '(') IF (I1 .EQ. 0) THEN I2 = LK ELSE I2 = I1 - 1 ENDIF I2 = MIN (I2, 16) NAM = ARGK(1:I2) C C Check if the argument is a constant or a variable. C IF (MAX (INDEX (ALPL, NAM(1:1)), INDEX (ALPU, NAM(1:1))) .GT. 0) $ THEN C C Check if the variable has subscripts and if it is dimensioned. C IX = ITAB (0, 0, NAM) IF (IX .EQ. 0) THEN CALL ERRMES (96, 0) WRITE (6, 3) NAM 3 FORMAT ('This Fortran keyword may not appear in a', $ ' read/write statement: ',A) CALL ABRT ELSEIF (I1 .EQ. 0 .AND. KDIM(IX) .NE. 0 .AND. $ KDIM(IX) .NE. -3) THEN CALL ERRMES (97, 0) WRITE (6, 4) NAM 4 FORMAT ('Dimensioned variables must be subscripted in this', $ ' form of read/write: ',A) CALL ABRT ENDIF ENDIF C C Check if it is read or a write. C IF (IRW .EQ. 1) THEN IF (ITK .LT. 8) THEN C C Read an ordinary non-MP variable. C WRITE (11, 5) UNIT(1:LUN), ARGK(1:LK) 5 FORMAT (6X,'READ (',A,', *) ',A) ELSEIF (ITK .NE. 10) THEN C C Read a MPI or MPR variable, possibly on multiple lines. C TMP1 = GETMP (6) WRITE (11, 6) UNIT(1:LUN), ARGK(1:LK), TMP1 6 FORMAT (6X,'CALL MPINP (',A,', ',A,', ',A,')') ELSE C C Read a MPC variable. C TMP1 = GETMP (6) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (11, 6) UNIT(1:LUN), TMP2, TMP1 WRITE (11, 6) UNIT(1:LUN), TMP3, TMP1 WRITE (11, 7) TMP2, TMP3, ARGK(1:LK) 7 FORMAT (6X,'CALL MPMMPC (',A,', ',A,', MPNW4, ',A,')') CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ELSE IF (ITK .EQ. 1) THEN C C Write an integer variable. C WRITE (11, 8) UNIT(1:LUN), ARGK(1:LK) 8 FORMAT (6X,'WRITE (',A,', ''(I12)'') ',A) ELSEIF (ITK .GE. 2 .AND. ITK .LE. 5) THEN C C Write an SP, DP, CO or DC variable. C WRITE (11, 9) UNIT(1:LUN), ARGK(1:LK) 9 FORMAT (6X,'WRITE (',A,', ''(1P2D25.15)'') ',A) ELSEIF (ITK .EQ. 6) THEN C C Write a character variable. C WRITE (11, 10) UNIT(1:LUN), ARGK(1:LK) 10 FORMAT (6X,'WRITE (',A,', ''(A)'') ',A) ELSEIF (ITK .EQ. 7) THEN C C Write a logical variable. C WRITE (11, 11) UNIT(1:LUN), ARGK(1:LK) 11 FORMAT (6X,'WRITE (',A,', ''(L4)'') ',A) ELSEIF (ITK .NE. 10) THEN C C Write a MPI or MPR variable. C TMP1 = GETMP (6) WRITE (11, 12) UNIT(1:LUN), ARG(K)(1:LAR(K)), NUMX(1:LX), $ TMP1 12 FORMAT (6X,'CALL MPOUT (',A,', ',A,', ',A,', ',A,')') ELSE C C Read a MPC variable. C TMP1 = GETMP (6) TMP2 = GETMP (9) TMP3 = GETMP (9) WRITE (11, 13) ARGK(1:LK), TMP2, TMP3 13 FORMAT (6X,'CALL MPMPCM (MPNW4, ',A,', ',A,', ',A,')') WRITE (11, 12) UNIT(1:LUN), TMP2, NUMX(1:LX), TMP1 WRITE (11, 12) UNIT(1:LUN), TMP3, NUMX(1:LX), TMP1 CALL RLTMP (TMP2) CALL RLTMP (TMP3) ENDIF ENDIF 100 CONTINUE C C Release any temporaries among the arguments. C DO 110 I = 1, NAR LI = LAR(I) IF (LI .EQ. 4) THEN IF (ARG(I)(1:2) .EQ. 'MP') THEN TMP1 = ARG(I)(1:4) CALL RLTMP (TMP1) ENDIF ENDIF 110 CONTINUE C GOTO 120 C 120 RETURN END C SUBROUTINE RLTMP (TMP) C C This releases temporary variable TMP for future use. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*4 TMP CHARACTER*1 CX C READ (TMP, 1, ERR = 110) CX, K 1 FORMAT (2X,A1,I1) C DO 100 I = 1, NTYP IF (CTM(I) .EQ. CX) GOTO 120 100 CONTINUE C 110 CALL ERRMES (98, 0) WRITE (6, 2) TMP 2 FORMAT ('RLTMP could not find temporary variable in table : ',A/ $ 'Please contact the author.') CALL ABRT C 120 ITMP(K,I) = 0 C RETURN END C SUBROUTINE TYPE (ITP, K1, LN) C C This processes type statements by delimiting variable names, inserting in C table if required (with types set to ITP) and placing any previously C declared MP variables in a separate statement, with dimensions corrected. C If ITP = 20, this is a flag that the statement being processed is an C external directive, and no types are set. K1 and LN are the indices of the C first (after the type name) and last non-blank characters in the statement. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ CHARACTER*1600 LINA, LINB CHARACTER*16 NAM CHARACTER*1 CJ CHARACTER*8 DIM1, DIM2, DIMY C C Output the original line as a comment, unless (1) this is a MP directive or C (2) this is a non-MP type statement and no MP type directives have yet C appeared in this routine. C IF (ITP .LT. 8 .AND. MPT .NE. 0) CALL OUTLIN (2, LN, LINE) C C Form the start of LINA and LINB. C KA = 12 NA = 0 LINA(1:KA-1) = ' REAL ' KB = K1 NB = 0 LINB(1:KB-1) = LINE(1:KB-1) LINB(KB:KB) = ' ' KB = KB + 1 C C Place the MP dimension into the character variables DIM1 and DIM2. C WRITE (DIMY, '(I8)') MXP + 4 I1 = NBLK (1, 8, DIMY) LD1 = 9 - I1 DIM1 = DIMY(I1:8) WRITE (DIMY, '(I8)') 2 * MXP + 8 I1 = NBLK (1, 8, DIMY) LD2 = 9 - I1 DIM2 = DIMY(I1:8) J1 = K1 C C Extract the next character from the line. C 100 IF (J1 .GT. LN) GOTO 130 J1 = NBLK (J1, LN, LINE) CJ = LINE(J1:J1) C C Check if it the start of a name. C IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) THEN C DO 110 J = J1, LN CJ = LINE(J:J) IF (MAX (INDEX (ALPL, CJ), INDEX (ALPU, CJ)) .NE. 0) GOTO 110 IF (INDEX (DIG, CJ) .NE. 0) GOTO 110 IF (INDEX (DEL, CJ) .NE. 0) GOTO 120 CALL ERRMES (99, 1) 110 CONTINUE C J = LN + 1 120 J2 = J - 1 NAM = LINE(J1:J2) C C Add entry to variable table. With a few exceptions, it should not already C be in the table. Exceptions: the function name, variables in the argument C list, variables in previous MP and conventional explicit type statements, C the special constants and the special functions. C IX = ITAB (0, 0, NAM) IF (IX .NE. 0 .AND. (ITP .GE. 8 .OR. ITP .LT. 8 .AND. $ MPLC(IX) .EQ. 1)) THEN CALL ERRMES (100, 0) WRITE (6, 1) NAM 1 FORMAT ('This reserved or previously defined name may not', $ ' appear in a type'/'statement: ',A) CALL ABRT ENDIF IX = ITAB (1, ITP, NAM) IF (IX .EQ. 0) THEN CALL ERRMES (101, 0) WRITE (6, 2) NAM 2 FORMAT ('This Fortran keyword may not appear in a type', $ ' statement: ',A) CALL ABRT ENDIF KTP = KTYP(IX) C C If this is a CMP+ directive, there should be no dimensions. C IF (ITP .GE. 8) THEN I1 = INDEX (LINE(J2:LN), '(') IF (I1 .NE. 0) THEN CALL ERRMES (102, 0) WRITE (6, 3) 3 FORMAT ('MP type directives may not specify dimensions.') CALL ABRT ENDIF J1 = J2 + 1 GOTO 100 ENDIF C C Check if this is a MP variable with a dimension. If so, copy it to LINA. C If it is a MP variable without a dimension, copy it to neither line. C IF (KTP .GE. 8) THEN IF (J2 .LT. LN) THEN J3 = NBLK (J2 + 1, LN, LINE) CJ = LINE(J3:J3) IF (CJ .EQ. '(') THEN KDEC(IX) = 1 NA = NA + 1 LINA(KA:KA+J2-J1) = LINE(J1:J2) KA = KA + J2 - J1 + 1 J1 = J3 C C Insert MP dimension as the first dimension. C LINA(KA:KA) = '(' IF (KTP .LT. 10) THEN LINA(KA+1:KA+LD1) = DIM1(1:LD1) KA = KA + LD1 + 1 ELSE LINA(KA+1:KA+LD2) = DIM2(1:LD2) KA = KA + LD2 + 1 ENDIF KDIM(IX) = 1 LINA(KA:KA) = ',' KA = KA + 1 J2 = MATCH (0, J1 + 1, LN, LINE) IF (J2 .EQ. 0) CALL ERRMES (103, 1) I1 = ISCAN (J1, J2, LINE) IF (I1 .NE. 0) THEN CALL ERRMES (104, 0) WRITE (6, 4) NAM 4 FORMAT ('The MP dimension on this variable is not', $ ' allowed: ',A) CALL ABRT ENDIF LINA(KA:KA+J2-J1-1) = LINE(J1+1:J2) KA = KA + J2 - J1 LINA(KA:KA+1) = ', ' KA = KA + 2 ENDIF ENDIF C C Otherwise this is an ordinary variable -- copy to LINB. C ELSE KDEC(IX) = 1 NB = NB + 1 LINB(KB:KB+J2-J1) = LINE(J1:J2) KB = KB + J2 - J1 + 1 IF (J1 .LT. LN) THEN J3 = NBLK (J2 + 1, LN, LINE) CJ = LINE(J3:J3) IF (CJ .EQ. '(') THEN KDIM(IX) = 1 LINB(KB:KB) = '(' KB = KB + 1 J1 = J3 J2 = MATCH (0, J1 + 1, LN, LINE) I1 = ISCAN (J1, J2, LINE) IF (I1 .NE. 0) THEN CALL ERRMES (105, 0) WRITE (6, 4) NAM CALL ABRT ENDIF LINB(KB:KB+J2-J1-1) = LINE(J1+1:J2) KB = KB + J2 - J1 ENDIF ENDIF LINB(KB:KB+1) = ', ' KB = KB + 2 ENDIF J1 = J2 + 1 GOTO 100 C C The only other character that should appear here is a comma. C ELSEIF (CJ .EQ. ',') THEN J1 = J1 + 1 GOTO 100 ELSE CALL ERRMES (106, 1) ENDIF C C Output LINA and LINB, provided there is something to output. C 130 IF (NA .GT. 0) CALL OUTLIN (1, KA - 3, LINA) IF (NB .GT. 0) CALL OUTLIN (1, KB - 3, LINB) IF (ITP .LT. 8 .AND. MPT .NE. 0) WRITE (11, 5) 5 FORMAT ('CMP<') C RETURN END C FUNCTION UCASE (NAM) C C This routine returns the character string NAM with upper case alphabetics. C+ PARAMETER (MAR = 40, MVAR = 400, MINT = 54, MSUB = 100, NDO = 50, $ NKY = 45, NOP = 14, NSF = 50, NTYP = 10) CHARACTER*1600 LINE, SARG CHARACTER*26 ALPL, ALPU CHARACTER*16 EPS, FNAM, KEYW, SFUN, SNAM, VAR CHARACTER*10 DEL, DIG CHARACTER*8 CTP, LOPR, UOPR CHARACTER*1 CTM COMMON /CMP1/ IEX, IMM, ISTP, ITE, KDO, LCT, LSAR, LSM, MPA, MPP, $ MPT, MSS, MXP, NSUB, NVAR COMMON /CMP2/ IDON(NDO), IMPL(26), IMPS(26), ITMP(9,NTYP), $ KTYP(MVAR), KCON(5), KDEC(MVAR), KDIM(MVAR), KSTP(0:MAR,MSUB), $ LVAR(MVAR), KOP(NOP), LOP(NOP), LEP(2), MPLC(MVAR), NARS(MSUB) COMMON /CMP3/ ALPL, ALPU, DEL, DIG, FNAM, LINE, SARG COMMON /CMP4/ CTM(NTYP), CTP(NTYP), EPS(2), KEYW(NKY), LOPR(NOP), $ SFUN(NSF), SNAM(MSUB), UOPR(NOP), VAR(MVAR) C+ C CHARACTER*16 NAMX, UCASE CHARACTER*(*) NAM CHARACTER*1 CJ C NAMX = ' ' LQ = LEN (NAM) C DO 100 J = 1, LQ CJ = NAM(J:J) I1 = INDEX (ALPL, CJ) IF (I1 .GT. 0) THEN NAMX(J:J) = ALPU(I1:I1) ELSE NAMX(J:J) = CJ ENDIF 100 CONTINUE C UCASE = NAMX RETURN END