#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: subs.f loops2.f
# Wrapped by dongarra@thud on Mon Dec 30 09:36:00 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'subs.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'subs.f'\"
else
echo shar: Extracting \"'subs.f'\" \(202081 characters\)
sed "s/^X//" >'subs.f' <<'END_OF_FILE'
X PROGRAM MAIN
X
C THIS PROGRAM WILL TEST THE ABILITY OF A SOFTWARE/HARDWARE
C SYSTEM IN REGARDS TO PARALLEL CONSTRUCTS.
C THE PROGRAM CONSISTS OF THE MAIN PROGRAM, DRIVERS THAT
C CALL AND TIME THE SUBROUTINE TO BE TESTED AND A COLLECTION
C OF SUBROUTINES FROM VARIOUS PROGRAMS. THESE SUBROUTINES HAVE BEEN
C ASSEMBLED FROM A VARIETY OF PROGRAMS AND AS SUCH THEY HAVE BEEN
C TAKEN OUT OF THEIR PROPER CONTEXT. THEY HAVE BEEN MODIFIED SO
C THAT THEY WILL EXECUTE IN A STAND ALONE MODE.
C THE PARAMETER 'NOROUT' SETS UP THE NUMBER OF SUBROUTINES
C TO TEST. IF ROUTINES ARE ADDED THIS PARAMETER MUST BE INCREASED
C TO THE CORRECT NUMBER. THE 'WTIMES' ARRAY CONTAINS THE WALL CLOCK
C TIMES FOR EACH SUBROUTINE THAT IS TESTED.
C THE 'IANS' ARRAY CONTAINS A O IF THE ROUTINE CALCULATED TO A
C PREDETERMINED RESULT AND A 1 IF IT DID NOT OBTAIN THE DESIRED RESULT.
C 'ITERNO IS A LOOP COUNTER THAT ALLOWS THE AMOUNT OF CPU TIME
C GENERATED TO BE VARIED. EACH DRIVER ROUTINE GENERATES AROUND .3 OF A
C CPU SECOND ON A CRAY XMP. THE DRIVER ALSO RETURNS THE CPU AND WALL
C CLOCK TIME FOR EACH ROUTINE. THERE IS A DRIVER FOR EACH ROUTINE
C THAT IS CALLED. THE 'IEX' ARRAY IS A SET OF FLAGS WHICH STATES
C WHAT ROUTINES TO TEST. A 1 IN IEX(1) WILL CALL DRIVER 1. A 0 WILL
C SKIP CALLING THAT ROUTINE. INSIDE OF EACH DRIVER THE ROUTINE TO BE
C TESTED MAY BE CALLED MORE THAN ONCE IN ORDER TO GENERATE ENOUGH
C CPU TIME. VARIABLE 'PRTALL' CONTROLS THE PRINTING OF INDIVIDUAL
C TIMINGS FOR EACH ROUTINE. IF IT IS 'TRUE' , THEN THE TIMES FOR
C EACH ROUTINE WILL BE PRINTED. IF 'FALSE' ONLY THE TOTAL TIMES WILL
C BE PRINTED. VARIABLE 'ITERNO' CONTROLS THE NUMBER OF TIMES THAT
C THE PROGRAMS WILL BE EXECUTED IN AN OUTER LOOP. THIS ALLOWS THE
C GENERATION OF MORE OR LESS TIME. THE MFLOPS ARE CALCULATED BY
C DIVIDING THE PREDETERMINED FLOPS BY THE WALL CLOCK TIME.
X
X PARAMETER ( NOROUT = 36 , NWORDS = 2100000)
X
X COMMON /DATA/DUMMY(NWORDS)
X COMMON /ERROR/ RELERR
X COMMON/WT/ WTIMES(NOROUT)
X COMMON /RESULTS/ IANS(NOROUT)
X
X DIMENSION IEX(NOROUT),FLOPS(NOROUT)
X
X INTEGER FLOPS,FLOPST
X REAL MFLOPS,MFLOPA
X LOGICAL PRTALL
X
X DATA PRTALL/.TRUE./
X DATA IEX/NOROUT*1/
X DATA ITERNO/1/
X DATA FLOPS/
X * 7303347, 5660969, 126307648, 270513504, 17668534, 173757577,
X * 291647851, 24518837, 11256093, 10452045, 28981773, 101543326,
X * 10304303, 221141203, 12815237, 33089704, 243753086, 10121093,
X * 190660062, 6913440, 23763905, 130846623, 4904591, 196496290,
X * 22563098, 12913459, 1323307, 13717990, 180614247, 334903167,
X * 136813658, 122346352, 2528014, 27661012, 36070850, 16585440/
X DATA CONST/1.E-06/
X
X RELERR = 1.E-9
X DO 1000 I = 1, NOROUT
X WTIMES(I) = 0
X IANS(I) = 0
X 1000 CONTINUE
X
X DO 1200 I = 1, ITERNO
X IF (IEX(1) .NE. 0) CALL D1
X IF (IEX(2) .NE. 0) CALL D2
X IF (IEX(3) .NE. 0) CALL D3
X IF (IEX(4) .NE. 0) CALL D4
X IF (IEX(5) .NE. 0) CALL D5
X IF (IEX(6) .NE. 0) CALL D6
X IF (IEX(7) .NE. 0) CALL D7
X IF (IEX(8) .NE. 0) CALL D8
X IF (IEX(9) .NE. 0) CALL D9
X IF (IEX(10) .NE. 0) CALL D10
X IF (IEX(11) .NE. 0) CALL D11
X IF (IEX(12) .NE. 0) CALL D12
X IF (IEX(13) .NE. 0) CALL D13
X IF (IEX(14) .NE. 0) CALL D14
X IF (IEX(15) .NE. 0) CALL D15
X IF (IEX(16) .NE. 0) CALL D16
X IF (IEX(17) .NE. 0) CALL D17
X IF (IEX(18) .NE. 0) CALL D18
X IF (IEX(19) .NE. 0) CALL D19
X IF (IEX(20) .NE. 0) CALL D20
X IF (IEX(21) .NE. 0) CALL D21
X IF (IEX(22) .NE. 0) CALL D22
X IF (IEX(23) .NE. 0) CALL D23
X IF (IEX(24) .NE. 0) CALL D24
X IF (IEX(25) .NE. 0) CALL D25
X IF (IEX(26) .NE. 0) CALL D26
X IF (IEX(27) .NE. 0) CALL D27
X IF (IEX(28) .NE. 0) CALL D28
X IF (IEX(29) .NE. 0) CALL D29
X IF (IEX(30) .NE. 0) CALL D30
X IF (IEX(31) .NE. 0) CALL D31
X IF (IEX(32) .NE. 0) CALL D32
X IF (IEX(33) .NE. 0) CALL D33
X IF (IEX(34) .NE. 0) CALL D34
X IF (IEX(35) .NE. 0) CALL D35
X IF (IEX(36) .NE. 0) CALL D36
X 1200 CONTINUE
X
X IFAILS = 0
X DO 1600 IDNUM = 1, NOROUT
X IF (IEX(IDNUM) .EQ. 0) GO TO 1400
X IF (IANS(IDNUM) .NE. 0) IFAILS = IFAILS + 1
X 1400 CONTINUE
X 1600 CONTINUE
X IF (IFAILS .EQ. 0) THEN
X PRINT 12
X ELSE
X PRINT 14
X DO 2000 IDNUM = 1, NOROUT
X IF (IEX(IDNUM) .EQ. 0) GO TO 1800
X IF (IANS(IDNUM) .NE. 0) PRINT 10, IDNUM
X 1800 CONTINUE
X 2000 CONTINUE
X ENDIF
X
X WLLTME = 0
X FLOPST = 0
X EXECS = 0
X GM = 1.
X DO 2400 IDNUM = 1, NOROUT
X IF (IEX(IDNUM) .EQ. 0) GO TO 2200
X WLLTME = WLLTME + WTIMES(IDNUM)
X IF (ITERNO .NE. 1) FLOPS(IDNUM) = FLOPS(IDNUM)*ITERNO
X FLOPST = FLOPST + FLOPS(IDNUM)
X MFLOPS = (FLOPS(IDNUM)/WTIMES(IDNUM))*CONST
X IF (PRTALL) PRINT 16, IDNUM, WTIMES(IDNUM), MFLOPS
X GM = GM * MFLOPS
X EXECS = EXECS + 1.
X 2200 CONTINUE
X 2400 CONTINUE
X
X MFLOPA = (FLOPST/WLLTME)*CONST
X
X GM = GM**(1./EXECS)
X PRINT 18, WLLTME, MFLOPA
X PRINT 20, GM
X STOP
X
X
X 10 FORMAT(1H ,'RESULTS FROM SUBROUTINE',I3,' WERE INVALID')
X 12 FORMAT(1H ,'ALL RESULTS WERE VALID')
X 14 FORMAT(1H ,'NOT ALL RESULTS WERE VALID. ')
X 16 FORMAT(1H ,'SUB',I2,2X,' WALL CLOCK SECONDS ',F6.2,2X
X 1 ,'MFLOPS ',F7.1)
X 18 FORMAT(1H ,/,' TOTAL WALL CLOCK SECONDS ',F8.3,/,
X 1 ' AVERAGE MFLOPS ',F8.3)
X 20 FORMAT(1H ,/,' GEOMETRIC MEAN ',F8.3)
X END
X
X SUBROUTINE CALLP0(ID,SUB)
X PARAMETER (CLOCK=6.0E-09)
X COMMON /OVERH/ OVER1,OVER2,OVER3
X COMMON/WT/ WTIMES(1)
X INTEGER WALLS, WALLE
X WALLS = RTC()
X CALL SUB
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP1 (ID, SUB, A)
X WALLS = RTC()
X CALL SUB (A)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP2 (ID, SUB, A, B)
X WALLS = RTC()
X CALL SUB (A, B)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP3 (ID, SUB, A, B, C)
X WALLS = RTC()
X CALL SUB (A, B, C)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP4 (ID, SUB, A, B, C, D)
X WALLS = RTC()
X CALL SUB (A, B, C, D)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP5 (ID, SUB, A, B, C, D, E)
X WALLS = RTC()
X CALL SUB (A, B, C, D, E)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP6 (ID, SUB, A, B, C, D, E, F)
X WALLS = RTC()
X CALL SUB (A, B, C, D, E, F)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP7 (ID, SUB, A, B, C, D, E, F, G)
X WALLS = RTC()
X CALL SUB (A, B, C, D, E, F, G)
X WALLE = RTC()
X GO TO 1000
X
X ENTRY CALLP8 (ID, SUB, A, B, C, D, E, F, G, H)
X WALLS = RTC()
X CALL SUB (A, B, C, D, E, F, G, H)
X WALLE = RTC()
X
X 1000 CONTINUE
X WTIMES(ID) = WTIMES(ID) + (FLOAT((WALLE-WALLS))*CLOCK)
X RETURN
X END
X
X SUBROUTINE INIT(VAR,CON,N,INC)
X COMPLEX CVAR(N),CCON
X DIMENSION VAR(N),IVAR(N)
X DO 1000 I = 1, N, INC
X VAR(I) = CON
X 1000 CONTINUE
X RETURN
X
X ENTRY IINIT (IVAR, ICON, N, INC)
X DO 1200 I = 1, N, INC
X IVAR(I) = ICON
X 1200 CONTINUE
X RETURN
X
X ENTRY CINIT (CVAR, CCON, N, INC)
X DO 1400 I = 1, N, INC
X CVAR(I) = CCON
X 1400 CONTINUE
X RETURN
X END
X
X SUBROUTINE RSUM(ID,VAR,N,RESULT)
X COMPLEX CVAR(N),CRSULT,CRES
X DIMENSION VAR(N),IVAR(N)
X COMMON /ERROR/ RELERR
X COMMON /RESULTS/ IANS(1)
X
X SUM = 0
X IANSWR = 0
X DO 1000 I = 1, N
X SUM = SUM + VAR(I)
X 1000 CONTINUE
X DIFF = ABS(RESULT-SUM)
X ESUM = ABS(RELERR*SUM)
X IF (DIFF .GT. ESUM) IANSWR = 1
X IF (IANSWR .NE. 0) PRINT 10, SUM, RESULT
X 10 FORMAT(' CALC ',E20.14,/,' EXPC ',E20.14)
X GO TO 1600
X
X ENTRY IISUM (ID, IVAR, N, IRSULT)
X IRES = 0
X IANSWR = 0
X DO 1200 I = 1, N
X IRES = IRES + IVAR(I)
X 1200 CONTINUE
X DIFF = ABS(IRSULT-IRES)
X ESUM = ABS(RELERR*IRES)
X IF (DIFF .GT. ESUM) IANSWR = 1
X GO TO 1600
X
X ENTRY CCSUM (ID, CVAR, N, CRSULT)
X CRES = 0
X IANSWR = 0
X DO 1400 I = 1, N
X CRES = CRES + CVAR(I)
X 1400 CONTINUE
X DIFF = ABS(CRSULT-CRES)
X ESUM = ABS(RELERR*CRES)
X IF (DIFF .GT. ESUM) IANSWR = 1
X 1600 CONTINUE
X IANS(ID) = IANS(ID) + IANSWR
X RETURN
X END
X SUBROUTINE D1
X PARAMETER (M1=400000,N=1000,M=100)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB001
X DIMENSION CON(4)
X DATA ANS /.23465302666590E+3/
X DATA CON(1)/.0014/,CON(2)/.005678/,CON(3)/.0010/
X DATA CON(4)/.001234/
X DO 1200 I = 1, 12
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP2 (1, SUB001, M, N)
X 1200 CONTINUE
X CALL RSUM (1, DUM1, M*N, ANS)
X RETURN
X END
X SUBROUTINE D2
X PARAMETER (N=10,M=10)
X PARAMETER (M1=N*M)
X COMMON /DATA/ DUM1(M),DUM2(M1),DUM3(M1),DUM4(M1),DUM5(M1)
X EXTERNAL SUB002
X DIMENSION CON(4),A2(N,M)
X DATA ANS /.35722539999999E+2/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 5000
X DO 1000 J = 1, 4
X CALL INIT (DUM5(J),CON(J),N*M,4)
X CALL INIT (DUM4(J),CON(J),N*M,4)
X CALL INIT (DUM3(J),CON(J),N*M,4)
X CALL INIT (DUM2(J),CON(J),N*M,4)
X CALL INIT (DUM1(J),CON(J),N*M,4)
X 1000 CONTINUE
X CALL CALLP7 (2, SUB002, M, N, DUM1, DUM2, DUM3, DUM4, DUM5)
X 1200 CONTINUE
X CALL RSUM (2, DUM2, M*N, ANS)
X RETURN
X END
X SUBROUTINE D3
X PARAMETER (N=100,M=100)
X PARAMETER (M1=M*N)
X COMMON /DATA/ DUM1(M),DUM2(M1),DUM3(M1),DUM4(M1),DUM5(M1)
X EXTERNAL SUB003
X DIMENSION CON(4)
X DATA ANS /.35722539999987E+4/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 1400
X DO 1000 J = 1, 4
X CALL INIT (DUM5(J),CON(J),N*M,4)
X CALL INIT (DUM4(J),CON(J),N*M,4)
X CALL INIT (DUM3(J),CON(J),N*M,4)
X CALL INIT (DUM2(J),CON(J),N*M,4)
X CALL INIT (DUM1(J),CON(J),N*M,4)
X 1000 CONTINUE
X CALL CALLP7 (3, SUB003, M, N, DUM1, DUM2, DUM3, DUM4, DUM5)
X 1200 CONTINUE
X CALL RSUM (3, DUM2, M*N, ANS)
X RETURN
X END
X SUBROUTINE D4
X PARAMETER (N=500,M=1000)
X PARAMETER (M1=M*N)
X COMMON /DATA/ DUM1(M),DUM2(M1),DUM3(M1),DUM4(M1),DUM5(M1)
X EXTERNAL SUB004
X DIMENSION CON(4)
X DATA ANS /.17861269999898E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 60
X DO 1000 J = 1, 4
X CALL INIT (DUM5(J),CON(J),M1,4)
X CALL INIT (DUM4(J),CON(J),M1,4)
X CALL INIT (DUM3(J),CON(J),M1,4)
X CALL INIT (DUM2(J),CON(J),M1,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP7 (4, SUB004, M, N, DUM1, DUM2, DUM3, DUM4, DUM5)
X 1200 CONTINUE
X CALL RSUM (4, DUM2, M*N, ANS)
X RETURN
X END
X SUBROUTINE D5
X PARAMETER (M1=21*101*101)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB005
X DIMENSION CON(4)
X DATA ANS /-.42552817357591E-3/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 20
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP1 (5, SUB005, SUM)
X 1200 CONTINUE
X CALL RSUM (5, SUM, 1, ANS)
X RETURN
X END
X SUBROUTINE D6
X PARAMETER (M1=6*100*100*10+9*10*100+5*100)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB006
X DIMENSION CON(4)
X DATA ANS /.80019108524855E+2/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 42
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (6, SUB006)
X 1200 CONTINUE
X CALL RSUM (6, DUM1, 200, ANS)
X RETURN
X END
X SUBROUTINE D7
X PARAMETER (M1=22*101*101)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB007
X DIMENSION CON(4)
X DATA ANS /.18733898409327E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 350
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (7, SUB007)
X 1200 CONTINUE
X CALL RSUM (7, DUM1, 3*101*101, ANS)
X RETURN
X END
X SUBROUTINE D8
X PARAMETER (M1=100*1000,M2=1000)
X COMMON /DATA/ DUM1(M1),DUM2(M2),DUM3(M2)
X EXTERNAL SUB008
X DIMENSION CON(4)
X DATA ANS /.18724499999957E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 8
X DO 1000 J = 1, 4
X CALL INIT (DUM3(J),CON(J),M2,4)
X CALL INIT (DUM2(J),CON(J),M2,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP6 (8, SUB008, 1000, 100, DUM2, DUM3, DUM1, IDUM)
X 1200 CONTINUE
X CALL RSUM (8, DUM1, M1, ANS)
X RETURN
X END
X SUBROUTINE D9
X PARAMETER (M1=27000+6*30,M2=27000*3)
X COMMON /DATA/ DUM1(M1),DUM2(M2)
X EXTERNAL SUB009
X DIMENSION CON(4)
X DATA ANS /.79003609513564E+3/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 100
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT (DUM2, 0, M2, 1)
X CALL CALLP4 (9, SUB009, .5, 1.5, 3.14, DUM2)
X 1200 CONTINUE
X CALL RSUM (9, DUM2, M2, ANS)
X RETURN
X END
X SUBROUTINE D10
X PARAMETER (M1=1600000,M2=12*12*24*6*24)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB010
X DIMENSION CON(4),IDUM(4)
X DATA IDUM/4*1/
X DATA ANS /-.10353899519837E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 2
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP3 (10, SUB010, 1, 1, IDUM)
X 1200 CONTINUE
X CALL RSUM (10, DUM1, M2, ANS)
X RETURN
X END
X SUBROUTINE D11
X PARAMETER (M1=1000+1000*1000)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB011
X DIMENSION CON(4)
X DATA ANS /.11420219304919E+0/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 7
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (11, SUB011)
X 1200 CONTINUE
X CALL RSUM (11, DUM1, 1000, ANS)
X RETURN
X END
X SUBROUTINE D12
X PARAMETER (II=101,JJ=101,KK=26)
X PARAMETER (IJK=II*JJ*KK)
X PARAMETER (M1=IJK+260)
X COMMON /DATA/ DUM1(M1),DUM2(IJK)
X EXTERNAL SUB012
X DIMENSION CON(4)
X DATA ANS /.37440876253074E+3/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 7
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT (DUM2, .00014576, IJK, 1)
X CALL CALLP1 (12, SUB012, DUM2)
X 1200 CONTINUE
X CALL RSUM (12, DUM2, IJK, ANS)
X RETURN
X END
X SUBROUTINE D13
X PARAMETER (M1=4*1000*100+5*1000+10*100)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB013
X DIMENSION CON(4)
X DATA ANS /.18872364107147E+1/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 6
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (13, SUB013)
X 1200 CONTINUE
X CALL RSUM (13, DUM1, 100, ANS)
X RETURN
X END
X SUBROUTINE D14
X PARAMETER (M1=1900000)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB014
X DIMENSION CON(4)
X DATA ANS /.47934719999997E+3/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 3
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (14, SUB014)
X 1200 CONTINUE
X CALL RSUM (14, DUM1, 48*72*32, ANS)
X RETURN
X END
X SUBROUTINE D15
X PARAMETER (M1=110000,M=10000,NM=172)
X COMMON /DATA/ DUM1(M1),DUM2(M),IDUM3(NM),IDUM4(NM)
X EXTERNAL SUB015
X DIMENSION CON(4)
X DATA ANS /.75126427075617E-1/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/3.1234/
X DO 1200 I = 1, 2
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT (DUM2, 0, M, 1)
X CALL IINIT (IDUM3, 0, NM, 1)
X CALL IINIT (IDUM4, 0, NM, 1)
X CALL CALLP3 (15, SUB015, DUM2, IDUM3, IDUM4)
X 1200 CONTINUE
X CALL RSUM (15, DUM2, M, ANS)
X RETURN
X END
X SUBROUTINE D16
X COMPLEX DUM1,DUM2,ANS,CON
X PARAMETER (M1=10000)
X COMMON /DATA/ I1,I2,I3,I4,I5,I6,I7,DUM1(M1),DUM2(2)
X EXTERNAL SUB016
X DIMENSION CON(4)
X DATA ANS /(-.36348926727874E-14,-.24624692117746E-14)/
X DATA CON(1)/(.14,.14)/,CON(2)/(.5678,.5678)/
X * ,CON(3)/(.001,.001)/,CON(4)/(.1234,.1234)/
X I1 = 5000
X I2 = 1
X I3 = 200
X I4 = 1
X I5 = 0
X I6 = 1
X I7 = 1
X DO 1000 J = 1, 4
X CALL CINIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X DUM2(1) = 1.
X DUM2(2) = 1.
X 1200 CONTINUE
X CALL CALLP2 (16, SUB016, DUM1, DUM2)
X CALL CCSUM (16, DUM1, 5000, ANS)
X RETURN
X END
X SUBROUTINE D17
X PARAMETER (NNX=44)
X PARAMETER (NNY=44)
X PARAMETER (NNZ=4)
X PARAMETER (MXC=11)
X PARAMETER (MXP=3)
X PARAMETER (MXW=5)
X PARAMETER (NXYN=NNX*NNY)
X PARAMETER (NBL=NXYN*NNZ)
X PARAMETER (NBLW=NBL+MXW)
X PARAMETER (M1=1589000,M2=60)
X COMMON /DATA/ DUM1(M1)
X COMMON /INTS/IDUM1(M2)
X EXTERNAL SUB017
X DIMENSION CON(4)
X DATA ANS /.29400934903364E+11/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 4
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL IINIT (IDUM1, 1, M2, 1)
X CALL CALLP0 (17, SUB017)
X 1200 CONTINUE
X CALL RSUM (17, DUM1, NBLW*MXC, ANS)
X RETURN
X END
X SUBROUTINE D18
X PARAMETER (M1=700000,M2=100000)
X COMMON /DATA/ DUM1(M1),DUM2(M2),DUM3(M2),DUM4(M2)
X EXTERNAL SUB018
X DIMENSION CON(4)
X DATA ANS /.25530009809248E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.19/,CON(4)/.1234/
X DO 1200 I = 1, 100
X DO 1000 J = 1, 4
X CALL INIT (DUM4(J),CON(J),M2,4)
X CALL INIT (DUM3(J),CON(J),M2,4)
X CALL INIT (DUM2(J),CON(J),M2,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP4 (18, SUB018, DUM1, DUM2, DUM3, DUM4)
X 1200 CONTINUE
X CALL RSUM (18, DUM4, M2, ANS)
X RETURN
X END
X SUBROUTINE D19
X PARAMETER (M1=688000)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB019
X DIMENSION CON(4)
X DATA ANS /.58082299171138E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 70
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (19, SUB019)
X 1200 CONTINUE
X CALL RSUM (19, DUM1, M1, ANS)
X RETURN
X END
X SUBROUTINE D20
X PARAMETER (M1=29791*9+100*5,M2=29791*5,M3=100)
X COMMON /DATA/ DUM1(M1),DUM2(M2),IDUM3(M3),IDUM4(M3)
X EXTERNAL SUB020
X DIMENSION CON(4)
X DATA ANS /.46771869999876E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT (DUM2, 3.14, M2, 1)
X CALL IINIT (IDUM3, 1, M3, 1)
X CALL IINIT (IDUM4, 1, M3, 1)
X 1200 CONTINUE
X CALL CALLP3 (20, SUB020, DUM2, IDUM3, IDUM4)
X CALL RSUM (20, DUM2, M2, ANS)
X RETURN
X END
X SUBROUTINE D21
X PARAMETER (M1=100000)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB021
X DIMENSION CON(4)
X DATA ANS /.35916589036686E+11/
X DATA CON(1)/.4/,CON(2)/.678/,CON(3)/.9/,
X * CON(4)/.234/
X DO 1200 I = 1, 3
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP4 (21, SUB021, 100, 100, 100, 0)
X 1200 CONTINUE
X CALL RSUM (21, DUM1, 6000, ANS)
X RETURN
X END
X SUBROUTINE D22
X PARAMETER (M1=625175,M2=31250)
X COMMON /DATA/ DUM1(M1),DUM2(M2)
X EXTERNAL SUB022
X DIMENSION CON(4)
X DATA ANS /.30710253481606E+8/
X DATA CON(1)/1.4/,CON(2)/5.678/,CON(3)/1.9/,CON(4)/1.234/
X DO 1200 I = 1, 14
X DO 1000 J = 1, 4
X CALL INIT (DUM2(J),CON(J),M2,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP4 (22, SUB022, DUM2, 1, 150, 5)
X 1200 CONTINUE
X CALL RSUM (22, DUM2, M2, ANS)
X RETURN
X END
X SUBROUTINE D23
X PARAMETER (M1=513000)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB023
X DIMENSION CON(4)
X DATA ANS /-.34586383403291E-2/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 1
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP1 (23, SUB023, SUM)
X 1200 CONTINUE
X CALL RSUM (23, SUM, 1, ANS)
X RETURN
X END
X SUBROUTINE D24
X PARAMETER (M1=10200,M2=10000)
X COMMON /DATA/ DUM1(M1),DUM2(M2),DUM3(M2),DUM4(M2)
X EXTERNAL SUB024
X DIMENSION CON(4)
X DATA ANS /-.20207560939631E+3/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.19/,CON(4)/.1234/
X DO 1200 I = 1, 21
X DO 1000 J = 1, 4
X CALL INIT (DUM2(J),CON(J),M2,4)
X CALL INIT (DUM3(J),CON(J),M2,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT (DUM4, .0001, M2, 1)
X CALL CALLP3 (24, SUB024, DUM2, DUM3, DUM4)
X 1200 CONTINUE
X CALL RSUM (24, DUM2, M2*2, ANS)
X RETURN
X END
X SUBROUTINE D25
X PARAMETER (M1=50000,IJ=28)
X COMMON /DATA/ DUM1(M1),DUM2(IJ)
X EXTERNAL SUB025
X DIMENSION CON(4)
X DATA ANS /.26728212215467E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 3
X DO 1000 J = 1, 4
X CALL INIT (DUM2(J),CON(J),IJ,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP1 (25, SUB025, DUM2)
X 1200 CONTINUE
X CALL RSUM (25, DUM2, IJ, ANS)
X RETURN
X END
X SUBROUTINE D26
X PARAMETER (M1=36,M2=47000,M3=44)
X COMPLEX DUM1,CCON
X COMMON /DATA/ DUM1(M1),DUM2(M2),DUM3(M3)
X EXTERNAL SUB026
X DIMENSION CON(4)
X DATA ANS /-.78506753418025E+2/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.19/,CON(4)/.1234/
X DO 1200 I = 1, 12
X DO 1000 J = 1, 4
X CALL INIT (DUM2(J),CON(J),M2,4)
X CCON = CON(J)
X CALL CINIT (DUM1(J),CCON,M1,4)
X 1000 CONTINUE
X CALL INIT (DUM3, 0, M3, 1)
X CALL CALLP1 (26, SUB026, DUM3)
X 1200 CONTINUE
X CALL RSUM (26, DUM3, M3, ANS)
X RETURN
X END
X SUBROUTINE D27
X PARAMETER (M1=100*100*100,IJ=40)
X COMMON /DATA/ DUM1(M1),DUM2(IJ)
X EXTERNAL SUB027
X DIMENSION CON(4)
X DATA ANS /.21304319999997E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 16
X DO 1000 J = 1, 4
X CALL INIT (DUM2(J),CON(J),IJ,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (27, SUB027)
X 1200 CONTINUE
X CALL RSUM (27, DUM1, M1, ANS)
X RETURN
X END
X SUBROUTINE D28
X PARAMETER (M1=200500)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB028
X DIMENSION CON(4)
X DATA ANS /.20164390072275E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 2
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP0 (28, SUB028)
X 1200 CONTINUE
X CALL RSUM (28, DUM1, 1000*100, ANS)
X RETURN
X END
X SUBROUTINE D29
X PARAMETER (M1=44000)
X COMMON /DATA/ DUM1(M1),DUM2(25)
X EXTERNAL SUB029
X DIMENSION CON(4)
X DATA ANS /.14228764570541E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X Do 1200 I = 1, 5
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL INIT(DUM2,0.0,25,1)
X CALL CALLP1 (29, SUB029, DUM2)
X 1200 CONTINUE
X CALL RSUM (29, DUM2, 25, ANS)
X RETURN
X END
X SUBROUTINE D30
X PARAMETER (M1=800000,I2=1000,J2=100)
X COMMON /DATA/ DUM1(M1),DUM2(J2)
X EXTERNAL SUB030
X DIMENSION CON(4)
X DATA ANS /.66713894216008E+5/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 200
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP3 (30, SUB030, J2, I2, DUM2)
X 1200 CONTINUE
X CALL RSUM (30, DUM2, J2, ANS)
X RETURN
X END
X SUBROUTINE D31
X PARAMETER (LS=1,LE=101,KS=1,KE=129,KD=129,LD=101,MD=129)
X PARAMETER (M1=MD*25,M2=LD*KD*125,M3=LD*75,M4=LD*5,M5=LD*KD*5)
X PARAMETER (M6=M2+M3+M4+M5)
X COMMON /DATA/ DUM1(M1),DUM2(M6)
X EXTERNAL SUB031
X DATA ANS / .32234316520824E+02 /
X DATA CON1 /.01 /, CON2 /1.0/
X DO 1000 I = 1, 6
X CALL INIT (DUM1, CON2, M1, 1)
X CALL INIT (DUM2, CON1, M6, 1)
X CALL CALLP0 (31, SUB031)
X 1000 CONTINUE
X CALL RSUM (31, DUM2, M5, ANS)
X RETURN
X END
X SUBROUTINE D32
X PARAMETER (JMAX=120,KMAX=23,LMAX=30)
X PARAMETER (M2=JMAX*KMAX*LMAX*17,M3=JMAX*JMAX*4)
X PARAMETER (M1=JMAX*KMAX*LMAX*6,M4=M2+M3+5)
X COMMON /DATA/ DUM1(M1),DUM2(M4)
X EXTERNAL SUB032
X DATA ANS /.12279940726070E+6/
X DATA CON1/3.14/,CON2/.5678/
X DO 1000 I = 1, 5
X CALL INIT (DUM1, CON2, M1, 1)
X CALL INIT (DUM2, CON1, M4, 1)
X CALL CALLP0 (32, SUB032)
X 1000 CONTINUE
X CALL RSUM (32, DUM1, M1, ANS)
X RETURN
X END
X SUBROUTINE D33
X PARAMETER (M1=15000,I2=1000)
X COMMON /DATA/ DUM1(M1),JM1(4*I2),JM2(I2),JM3(I2),JM4(I2)
X COMMON /DATA/ JM5(I2),JM6(I2)
X EXTERNAL SUB033
X DIMENSION CON(4)
X DATA ANS /.36315788655113E+4/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 15
X DO 1000 J = 1, 4
X CALL IINIT (JM1(J),J,9000,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP7 (33, SUB033, JM1, JM2, JM3, JM4, JM5, JM6, I2)
X 1200 CONTINUE
X CALL RSUM (33, DUM1, I2*5, ANS)
X RETURN
X END
X SUBROUTINE D34
X PARAMETER (M1=37*100*100)
X COMMON /DATA/ DUM1(M1)
X EXTERNAL SUB034
X DIMENSION CON(4)
X DATA ANS /.61065011581289E+6/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 10
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP2 (34, SUB034, 100, 100)
X 1200 CONTINUE
X CALL RSUM (34, DUM1, 100*100, ANS)
X RETURN
X END
X SUBROUTINE D35
X PARAMETER (M1=500000,I2=96,J2=24,K2=24)
X COMMON /DATA/ DUM1(M1),DUM2(M1),DUM3(M1),DUM4(M1)
X EXTERNAL SUB035
X DIMENSION CON(4)
X DATA ANS /.13346223580218E+4/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1200 I = 1, 2
X DO 1000 J = 1, 4
X CALL INIT (DUM4(J),CON(J),M1,4)
X CALL INIT (DUM3(J),CON(J),M1,4)
X CALL INIT (DUM2(J),CON(J),M1,4)
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP4 (35, SUB035, I2, J2, K2, RTRMS)
X 1200 CONTINUE
X CALL RSUM (35, RTRMS, 1, ANS)
X RETURN
X END
X SUBROUTINE D36
X PARAMETER (M1=241000,N=20,M=80)
X COMMON /DATA/ DUM1(M1),DUM2(N*M)
X EXTERNAL SUB036
X DIMENSION CON(4)
X DATA ANS /.32343671293395E+4/
X DATA CON(1)/.14/,CON(2)/.5678/,CON(3)/.0010/,CON(4)/.1234/
X DO 1000 J = 1, 4
X CALL INIT (DUM1(J),CON(J),M1,4)
X 1000 CONTINUE
X CALL CALLP3 (36, SUB036, N, M, DUM2)
X CALL RSUM (36, DUM2, N*M, ANS)
X RETURN
X END
X SUBROUTINE SUB001(M,N)
X PARAMETER (MM=100,NN=1000)
X COMMON /DATA/ A(MM,NN)
X COMMON /DATA/ X(MM,NN),Y(MM,NN),Z(MM,NN)
X
X S = .0001
X DO 1400 I = 1, M
X DO 1000 J = 1, N
X A(I,J) = A(I,J) + 1
X IF (A(I,J) .EQ. 0) GO TO 1200
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X
X DO 1800 I = 1, M
X DO 1600 J = 1, N
X A(I,J) = 1
X 1600 CONTINUE
X A(I,I) = A(I,I) + 1
X 1800 CONTINUE
X
X DO 2200 I = 1, M
X DO 2000 J = 1, N
X A(I,J) = S
X Y(I,J) = (X(I,J)+Z(I,J))*S
X S = Y(I,J) + X(I,J)
X 2000 CONTINUE
X 2200 CONTINUE
X
X DO 2600 I = 1, M
X DO 2400 J = 1, N
X X(I,J) = Y(I,J)
X Y(I,J) = X(I,J)*Z(I,J)
X 2400 CONTINUE
X 2600 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB002(M,N,A1,A2,B2,C2,D2)
X DIMENSION A2(M,N)
X REAL A1(M)
X REAL B2(M,N)
X REAL C2(M,N)
X REAL D2(M,N)
X DATA S1/0/
C
C DOUBLY DIMENSIONED ARRAY - SIMPLE ASSIGNMENT
C
X DO 1200 I = 1, N
X DO 1000 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X 1000 CONTINUE
X 1200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH SCALAR MULTIPLIER
C
X DO 1600 I = 1, N
X DO 1400 J = 1, M
X A2(J,I) = B2(J,I) + S1*C2(J,I)
X 1400 CONTINUE
X 1600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY - WITH REUSED VALUE
C
X DO 2000 I = 1, N
X DO 1800 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X B2(J,I) = A2(J,I) + D2(J,I)
X 1800 CONTINUE
X 2000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE SCALAR TEMPORARY
C
X DO 2400 I = 1, N
X DO 2200 J = 1, M
X A06 = B2(J,I) + C2(J,I)
X A2(J,I) = A06*D2(J,I)
X 2200 CONTINUE
X 2400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE ARRAY TEMPORARY
C
X DO 2800 I = 1, N
X DO 2600 J = 1, M
X A1(J) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(J)*D2(J,I)
X 2600 CONTINUE
X 2800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB003(M,N,A1,A2,B2,C2,D2)
X DIMENSION A2(M,N)
X REAL A1(M)
X REAL B2(M,N)
X REAL C2(M,N)
X REAL D2(M,N)
X DATA S1/0/
C
C DOUBLY DIMENSIONED ARRAY - SIMPLE ASSIGNMENT
C
X DO 1200 I = 1, N
X DO 1000 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X 1000 CONTINUE
X 1200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH SCALAR MULTIPLIER
C
X DO 1600 I = 1, N
X DO 1400 J = 1, M
X A2(J,I) = B2(J,I) + S1*C2(J,I)
X 1400 CONTINUE
X 1600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY - WITH REUSED VALUE
C
X DO 2000 I = 1, N
X DO 1800 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X B2(J,I) = A2(J,I) + D2(J,I)
X 1800 CONTINUE
X 2000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE SCALAR TEMPORARY
C
X DO 2400 I = 1, N
X DO 2200 J = 1, M
X A06 = B2(J,I) + C2(J,I)
X A2(J,I) = A06*D2(J,I)
X 2200 CONTINUE
X 2400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE ARRAY TEMPORARY
C
X DO 2800 I = 1, N
X DO 2600 J = 1, M
X A1(J) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(J)*D2(J,I)
X 2600 CONTINUE
X 2800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB004(M,N,A1,A2,B2,C2,D2)
X DIMENSION A2(M,N)
X REAL A1(M)
X REAL B2(M,N)
X REAL C2(M,N)
X REAL D2(M,N)
X DATA S1/0/
C
C DOUBLY DIMENSIONED ARRAY - SIMPLE ASSIGNMENT
C
X DO 1200 I = 1, N
X DO 1000 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X 1000 CONTINUE
X 1200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH SCALAR MULTIPLIER
C
X DO 1600 I = 1, N
X DO 1400 J = 1, M
X A2(J,I) = B2(J,I) + S1*C2(J,I)
X 1400 CONTINUE
X 1600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY - WITH REUSED VALUE
C
X DO 2000 I = 1, N
X DO 1800 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X B2(J,I) = A2(J,I) + D2(J,I)
X 1800 CONTINUE
X 2000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE SCALAR TEMPORARY
C
X DO 2400 I = 1, N
X DO 2200 J = 1, M
X A06 = B2(J,I) + C2(J,I)
X A2(J,I) = A06*D2(J,I)
X 2200 CONTINUE
X 2400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE ARRAY TEMPORARY
C
X DO 2800 I = 1, N
X DO 2600 J = 1, M
X A1(J) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(J)*D2(J,I)
X 2600 CONTINUE
X 2800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB005(SUM)
X PARAMETER(II=101)
X COMMON /DATA/
X 1 R(II,II),Z(II,II),U(II,II),V(II,II),AJ(II,II)
X 2,ENERGY(II,II),P(II,II),Q(II,II),TEMP(II,II)
X 3,RHO(II,II),DTAU(II,II),MASS(II,II),NBC(II,II)
X REAL MASS
X COMMON /DATA/
X 1 A(II,II),B(II,II),CBB(II,II),DBB(II,II)
X 2,ODTEMP(II,II),SIG(II,II),CC(II,II)
X COMMON /DATA/ SUMKV(II),SUMLV(II),DENOMV(II),TEMPRV(II)
X DATA TFLR /0.0001/
X LMNP = 2
X KMNP = 2
X LMX = 100
X KMX = 100
X LMN = 2
X KMN = 2
X DTNPH = 3.14
X DO 1200 L = LMNP, LMX
X DO 1000 K = KMNP, KMX
X CC(K,L) = (0.0001*SQRT(TEMP(K,L))*TEMP(K,L)**2)/AJ(K,L)
X SIG(K,L) = MASS(K,L)*SIG(K,L)/DTNPH
X ODTEMP(K,L) = TEMP(K,L)
X 1000 CONTINUE
X 1200 CONTINUE
X
X
X DO 1600 L = LMNP, LMX
X DO 1400 K = KMN, KMX
X DBB(K,L) = (2.0*CC(K+1,L)*CC(K,L))/(CC(K+1,L)+CC(K,L))*(0.5*(R
X 1 (K,L-1)+R(K,L))*((R(K,L)-R(K,L-1))**2+(Z(K,L)-Z(K,L-1))**2)
X 2 )
X 1400 CONTINUE
X 1600 CONTINUE
X
X DO 2000 K = KMNP, KMX
X DO 1800 L = LMN, LMX
X CBB(K,L) = (2.0*CC(K,L)*CC(K,L+1))/(CC(K,L)+CC(K,L+1))*(0.5*(R
X 1 (K-1,L)+R(K,L))*((R(K,L)-R(K-1,L))**2+(Z(K,L)-Z(K-1,L))**2)
X 2 )
X 1800 CONTINUE
X 2000 CONTINUE
X
X
X DO 2400 L = LMNP, LMX
X DO 2200 K = KMNP, KMX
X DENOMV(K) = SIG(K,L) + CBB(K,L) + CBB(K,L-1)*(1.-A(K,L-1))
X A(K,L) = CBB(K,L)/DENOMV(K)
X B(K,L) = (SIG(K,L)*TEMP(K,L)+CBB(K,L-1)*B(K,L-1))/DENOMV(K)
X 2200 CONTINUE
X 2400 CONTINUE
X
X ML = LMX + 1
X DO 2800 L = LMNP, LMX
X ML = ML - 1
X DO 2600 K = KMNP, KMX
X TEMP(K,ML) = A(K,ML)*TEMP(K,ML+1) + B(K,ML)
X 2600 CONTINUE
X 2800 CONTINUE
X
X DO 3200 K = KMNP, KMX
X DO 3000 L = LMNP, LMX
X DENOMV(L) = SIG(K,L) + DBB(K,L) + DBB(K-1,L)*(1.-A(K-1,L))
X A(K,L) = DBB(K,L)/DENOMV(L)
X B(K,L) = (SIG(K,L)*TEMP(K,L)+DBB(K-1,L)*B(K-1,L))/DENOMV(L)
X 3000 CONTINUE
X 3200 CONTINUE
X
X ML = KMX + 1
X DO 3600 K = KMNP, KMX
X ML = ML - 1
X DO 3400 L = LMNP, LMX
X TEMP(ML,L) = A(ML,L)*TEMP(ML+1,L) + B(ML,L)
X 3400 CONTINUE
X 3600 CONTINUE
X
X YE = -1.0
X DO 4400 L = LMNP, LMX
X DO 3800 K = KMNP, KMX
X TEMP(K,L) = AMAX1(TEMP(K,L),TFLR)
X TEMPRV(K) = ABS((TEMP(K,L)-ODTEMP(K,L))/ODTEMP(K,L))
X 3800 CONTINUE
X
X DO 4200 K = KMNP, KMX
X IF (TEMPRV(K) .LE. YE) GO TO 4000
X YE = TEMPRV(K)
X KE = K
X LE = L
X 4000 CONTINUE
X 4200 CONTINUE
X
X 4400 CONTINUE
X KEN = KE
X LEN = LE
X
X SUM = 0.0
X DO 4600 K = KMN, KMX
X SUMKV(K) = CBB(K,LMN)*(TEMP(K,LMN)-TEMP(K,LMN+1)) + CBB(K,LMX)*(
X 1 TEMP(K,LMX+1)-TEMP(K,LMX))
X 4600 CONTINUE
X
X DO 4800 L = LMN, LMX
X SUMLV(L) = DBB(KMN,L)*(TEMP(KMN,L)-TEMP(KMN+1,L)) + DBB(KMX,L)*(
X 1 TEMP(KMX+1,L)-TEMP(KMX,L))
X 4800 CONTINUE
X
X DO 5000 K = KMN, KMX
X SUM = SUM + SUMKV(K)
X 5000 CONTINUE
X DO 5200 L = LMN, LMX
X SUM = SUM + SUMLV(L)
X 5200 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB006
X PARAMETER (NY=10,NX=100,NZ=100)
X COMMON /DATA/
X * U(NZ),T(NZ),
X * UX(NX,NY,NZ),VY(NX,NY,NZ),POTT(NX,NY,NZ),DKZM(NX,NY,NZ),
X * DKZH(NX,NY,NZ),WZ(NX,NY,NZ),OBUK(NX,NY),USTR(NX,NY),
X * VDEP(NX,NY),TAVR(NX,NY),TSTR(NX,NY),STEPH(NX,NY),Z0(NX,NY),
X * ELEV(NX,NY),HMIX(NX,NY),TM(NZ),VM(NZ),UM(NZ)
X DO 2000 J = 1, NY
X DO 1800 I = 1, NX
X ZMH = HMIX(I,J)
X ZNOT = Z0(I,J)
X IF (ELEV(I,J) .LT. 0) THEN
X USTAR = MAX(USTR(I,J),0.001)
X ZNOT = 3.905E-5/USTAR + 1.6046E-3*USTAR**2 - 1.747E-4
X Z0(I,J) = ZNOT
X ENDIF
X IF (J.EQ.1 .OR. J.EQ.NY) THEN
X IF (I.EQ.1 .OR. I.EQ.NX) THEN
X DO 1000 K = 1, NZ
X TX = 0.5*POTT(I,J,K)
X WUX = 0.5*UX(I,J,K)
X WVX = 0.5*VY(I,J,K)
X
X TY = 0.5*POTT(I,J,K)
X WUY = 0.5*UX(I,J,K)
X WVY = 0.5*VY(I,J,K)
X XW = (UX(I,J,K)+WUX+WUY)/2. + UM(K)
X YW = (VY(I,J,K)+WVX+WVY)/2. + VM(K)
X U(K) = SQRT(XW*XW+YW*YW)
X T(K) = (POTT(I,J,K)+TX+TY)/2. + TM(K)
X 1000 CONTINUE
X ELSE
X DO 1200 K = 1, NZ
X TX = 0.25*(POTT(I-1,J,K)+POTT(I+1,J,K))
X WUX = 0.25*(UX(I-1,J,K)+UX(I+1,J,K))
X WVX = 0.25*(VY(I-1,J,K)+VY(I+1,J,K))
X
X TY = 0.5*POTT(I,J,K)
X WUY = 0.5*UX(I,J,K)
X WVY = 0.5*VY(I,J,K)
X XW = (UX(I,J,K)+WUX+WUY)/2. + UM(K)
X YW = (VY(I,J,K)+WVX+WVY)/2. + VM(K)
X U(K) = SQRT(XW*XW+YW*YW)
X T(K) = (POTT(I,J,K)+TX+TY)/2. + TM(K)
X 1200 CONTINUE
X ENDIF
X ELSE
X IF (I.EQ.1 .OR. I.EQ.NX) THEN
X DO 1400 K = 1, NZ
X TX = 0.5*POTT(I,J,K)
X WUX = 0.5*UX(I,J,K)
X WVX = 0.5*VY(I,J,K)
X
X TY = 0.25*(POTT(I,J-1,K)+POTT(I,J+1,K))
X WUY = 0.25*(UX(I,J-1,K)+UX(I,J+1,K))
X WVY = 0.25*(VY(I,J-1,K)+VY(I,J+1,K))
X XW = (UX(I,J,K)+WUX+WUY)/2. + UM(K)
X YW = (VY(I,J,K)+WVX+WVY)/2. + VM(K)
X U(K) = SQRT(XW*XW+YW*YW)
X T(K) = (POTT(I,J,K)+TX+TY)/2. + TM(K)
X 1400 CONTINUE
X ELSE
X DO 1600 K = 1, NZ
X TX = 0.25*(POTT(I-1,J,K)+POTT(I+1,J,K))
X WUX = 0.25*(UX(I-1,J,K)+UX(I+1,J,K))
X WVX = 0.25*(VY(I-1,J,K)+VY(I+1,J,K))
X
X TY = 0.25*(POTT(I,J-1,K)+POTT(I,J+1,K))
X WUY = 0.25*(UX(I,J-1,K)+UX(I,J+1,K))
X WVY = 0.25*(VY(I,J-1,K)+VY(I,J+1,K))
X XW = (UX(I,J,K)+WUX+WUY)/2. + UM(K)
X YW = (VY(I,J,K)+WVX+WVY)/2. + VM(K)
X U(K) = SQRT(XW*XW+YW*YW)
X T(K) = (POTT(I,J,K)+TX+TY)/2. + TM(K)
X 1600 CONTINUE
X ENDIF
X ENDIF
X 1800 CONTINUE
X 2000 CONTINUE
X DO 2600 J = 1, NY
X DO 2400 I = 1, NX
X DL = OBUK(I,J)
X TMES = TAVR(I,J)
X USTAR = USTR(I,J)
X ZMH = MAX(40.,HMIX(I,J))
X ZMH = MIN(ZMH,2000.)
X HMIX(I,J) = ZMH
X ZNOT = Z0(I,J)
X DEPFAC = USTAR/500.
X IF (DL .GE. 0) THEN
X VDEP(I,J) = DEPFAC
X ELSE
X ZC = ZMH/DL
X IF (ZC .LT. (-30.)) THEN
X VDEP(I,J) = 0.5*DEPFAC*(-ZC)**0.6666667
X ELSE
X VDEP(I,J) = DEPFAC*(1.+(-300/DL)**0.6666667)
X ENDIF
X ENDIF
X VDEP(I,J) = MIN(0.004,VDEP(I,J))
X DO 2200 K = 1, NZ
X DKZM(I,J,K) = U(K)
X DKZH(I,J,K) = T(K)
X 2200 CONTINUE
X 2400 CONTINUE
X 2600 CONTINUE
X RETURN
X END
X SUBROUTINE SUB007
X PARAMETER(II=101)
X COMMON /DATA/
X * AJ(II,II),
X 1 R(II,II),Z(II,II),U(II,II),V(II,II)
X 2,ENERGY(II,II),P(II,II),Q(II,II),TEMP(II,II)
X 3,RHO(II,II),DTAU(II,II),MASS(II,II),NBC(II,II)
X REAL MASS
X
X COMMON /DATA/ AU(II),AW(II),AUW(II),AJ1(II),AJ3(II)
X 1,VN(II),VNP(II),VOL(II)
X DATA P1D6 /0.166666666666667/
X DATA VCUT /1.0E-10/
X KMNP = 2
X LMNP = 2
X LMN = 2
X KMN = 2
X LMX = 100
X KMX = 100
X DTN = .05
X DTNPH = 3.14
X
X DO 1200 L = LMN, LMX
X DO 1000 K = KMN, KMX
X AU(K) = (P(K,L)+Q(K,L))*(Z(K,L-1)-Z(K-1,L)) + (P(K+1,L)+Q(K+1,
X 1 L))*(Z(K+1,L)-Z(K,L-1)) + (P(K,L+1)+Q(K,L+1))*(Z(K-1,L)-Z(K
X 2 ,L+1)) + (P(K+1,L+1)+Q(K+1,L+1))*(Z(K,L+1)-Z(K+1,L))
X AW(K) = (P(K,L)+Q(K,L))*(R(K,L-1)-R(K-1,L)) + (P(K+1,L)+Q(K+1,
X 1 L))*(R(K+1,L)-R(K,L-1)) + (P(K,L+1)+Q(K,L+1))*(R(K-1,L)-R(K
X 2 ,L+1)) + (P(K+1,L+1)+Q(K+1,L+1))*(R(K,L+1)-R(K+1,L))
X AUW(K) = RHO(K,L)*AJ(K,L) + RHO(K+1,L)*AJ(K+1,L) + RHO(K,L+1)*
X 1 AJ(K,L+1) + RHO(K+1,L+1)*AJ(K+1,L+1)
X AUW(K) = 2./AUW(K)
X AU(K) = -AU(K)*AUW(K)
X AW(K) = AW(K)*AUW(K)
X U(K,L) = U(K,L) + DTN*AU(K)
X V(K,L) = V(K,L) + DTN*AW(K)
X 1000 CONTINUE
X 1200 CONTINUE
X
X DO 1600 L = LMN, LMX
X DO 1400 K = KMN, KMX
X R(K,L) = R(K,L) + DTNPH*U(K,L)
X Z(K,L) = Z(K,L) + DTNPH*V(K,L)
X 1400 CONTINUE
X 1600 CONTINUE
X
X DO 2000 L = LMNP, LMX
X DO 1800 K = KMNP, KMX
X AJ1(K) = R(K,L)*(Z(K-1,L)-Z(K,L-1)) + R(K-1,L)*(Z(K,L-1)-Z(K,L
X 1 )) + R(K,L-1)*(Z(K,L)-Z(K-1,L))
X IF (AJ1(K) .EQ. 0) AJ1(K) = P1D6
X AJ3(K) = R(K-1,L)*(Z(K-1,L-1)-Z(K,L-1)) + R(K-1,L-1)*(Z(K,L-1)
X 1 -Z(K-1,L)) + R(K,L-1)*(Z(K-1,L)-Z(K-1,L-1))
X IF (AJ3(K) .EQ. 0) AJ3(K) = P1D6
X AJ(K,L) = 0.5*(AJ1(K)+AJ3(K))
X VOL(K) = P1D6*((R(K,L)+R(K-1,L)+R(K,L-1))*AJ1(K)+(R(K-1,L)+R(K
X 1 -1,L-1)+R(K,L-1))*AJ3(K))
X VN(K) = 1.0/RHO(K,L)
X RHO(K,L) = MASS(K,L)/VOL(K)
X VNP(K) = 1.0/RHO(K,L)
X DTAU(K,L) = VNP(K) - VN(K)
X 1800 CONTINUE
X 2000 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB008(NM,N,D,E,Z,IERR)
C
X DIMENSION D(N),E(N),Z(NM,N)
X IERR = 0
C
X DO 1000 I = 2, N
X E(I-1) = E(I)
X 1000 CONTINUE
C
X F = 0.0
X TST1 = 0.0
X E(N) = 0.0
C
X DO 2600 L = 1, N
X H = ABS(D(L)) + ABS(E(L))
X TST1 = AMAX1(H,TST1)
C
X DO 1200 M = L, N
X TST2 = TST1 + ABS(E(M))
X IF (TST2 .EQ. TST1) GO TO 1400
X 1200 CONTINUE
C
X 1400 CONTINUE
X IF (M .EQ. L) GO TO 2400
X L1 = L + 1
X L2 = L1 + 1
X G = D(L)
X P = (D(L1)-G)/(2.0*E(L))
X R = 3.14
X D(L) = E(L)/(P+SIGN(R,P))
X D(L1) = E(L)*(P+SIGN(R,P))
X DL1 = D(L1)
X H = G - D(L)
X IF (L2 .GT. N) GO TO 1800
C
X DO 1600 I = L2, N
X D(I) = D(I) - H
X 1600 CONTINUE
C
X 1800 CONTINUE
X F = F + H
X P = D(M)
X C = 1.0
X C2 = C
X EL1 = E(L1)
X S = 0.0
X MML = M - L
X DO 2200 II = 1, MML
X C3 = C2
X C2 = C
X S2 = S
X I = M - II
X G = C*E(I)
X H = C*P
X R = 3.14
X E(I+1) = S*R
X S = E(I)/R
X C = P/R
X P = C*D(I) - S*G
X D(I+1) = H + S*(C*G+S*D(I))
X DO 2000 K = 1, N
X H = Z(K,I+1)
X Z(K,I+1) = S*Z(K,I) + C*H
X Z(K,I) = C*Z(K,I) - S*H
X 2000 CONTINUE
C
X 2200 CONTINUE
C
X P = -S*S2*C3*EL1*E(L)/DL1
X E(L) = S*P
X D(L) = C*P
X TST2 = TST1 + ABS(E(L))
X 2400 CONTINUE
X D(L) = D(L) + F
X 2600 CONTINUE
X
X DO 3600 II = 2, N
X I = II - 1
X K = I
X P = D(I)
C
X DO 3000 J = II, N
X IF (D(J) .GE. P) GO TO 2800
X K = J
X P = D(J)
X 2800 CONTINUE
X 3000 CONTINUE
C
X IF (K .EQ. I) GO TO 3400
X D(K) = D(I)
X D(I) = P
C
X DO 3200 J = 1, N
X P = Z(J,I)
X Z(J,I) = Z(J,K)
X Z(J,K) = P
X 3200 CONTINUE
C
X 3400 CONTINUE
X 3600 CONTINUE
C
X RETURN
X END
X SUBROUTINE SUB009(S,T,U,FNDS)
X COMMON /DATA/ FN(27000),SQ(30),TQ(30),UQ(30)
X 1 , DSQ(30),DTQ(30),DUQ(30)
X DIMENSION FNDS(27000,3)
X
X A = 0.5
X B = S*S
X SQ(1) = A*(B-S)
X SQ(2) = A + A - B
X SQ(3) = A*(B+S)
X B = T*T
X TQ(1) = A*(B-T)
X TQ(2) = A + A - B
X TQ(3) = A*(B+T)
X B = U*U
X UQ(1) = A*(B-U)
X UQ(2) = A + A - B
X UQ(3) = A*(B+U)
X
X L = 0
X DO 1400 IU = 1, 30
X UQI = UQ(IU)
X DO 1200 IT = 1, 30
X TQI = TQ(IT)
X DO 1000 IS = 1, 30
X L = L + 1
X FN(L) = UQI*TQI*SQ(IS)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X
X A = 0.5
X DSQ(1) = S - A
X DSQ(2) = (-S) - S
X DSQ(3) = S + A
X DTQ(1) = T - A
X DTQ(2) = (-T) - T
X DTQ(3) = T + A
X DUQ(1) = U - A
X DUQ(2) = (-U) - U
X DUQ(3) = U + A
X
X L = 0
X DO 2000 IU = 1, 30
X UQI = UQ(IU)
X DUQI = DUQ(IU)
X DO 1800 IT = 1, 30
X TQI = TQ(IT)
X DTQI = DTQ(IT)
X DO 1600 IS = 1, 30
X L = L + 1
X FNDS(L,1) = UQI*TQI*DSQ(IS)
X FNDS(L,2) = UQI*DTQI*SQ(IS)
X FNDS(L,3) = DUQI*TQI*SQ(IS)
X 1600 CONTINUE
X 1800 CONTINUE
X 2000 CONTINUE
X END
X SUBROUTINE SUB010(NSRC,IPAR,ISLECT)
X PARAMETER (ISIZE1=12, ISIZE2=24)
X PARAMETER (MAXVOL=ISIZE1**3*ISIZE2, NC=3, NC8=8*NC)
X PARAMETER (NN1=ISIZE1/2, NN48=NC8*MAXVOL/2, NC4=4*NC)
X PARAMETER (NSC=ISIZE1**3)
X COMMON /DATA/ XX(NC8,NN1,ISIZE1,ISIZE1,ISIZE2)
X COMMON /DATA/ PP(NC8,NN1,ISIZE1,ISIZE1,ISIZE2)
X COMMON /DATA/ RQ(NN48)
X COMMON /DATA/ PH(2,NC,2,2,NSC)
X COMMON /DATA/ PN(2,NC,2,2,NSC)
X
X DIMENSION PNS(NC8,ISIZE1,ISIZE1,ISIZE1)
X DIMENSION ISLECT(4),RX(NN48)
X DIMENSION PQ(2,NC,2,2,NSC,ISIZE2)
X EQUIVALENCE (RX,XX), (PP,PQ)
X EQUIVALENCE(PN,PNS)
X B0 = 3.14
X DO 6600 IT = 1, ISIZE2
X IF (NSRC .EQ. 1) THEN
X DO 1800 IMRE = 1, 2
X DO 1600 MUS = 1, 2
X DO 1400 MUG = 1, 2
X DO 1200 IC = 1, NC
X DO 1000 ISC = 1, NSC
X PH(IMRE,IC,MUS,MUG,ISC) = PQ(IMRE,IC,MUS,MUG,ISC,
X 1 IT)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X 1600 CONTINUE
X 1800 CONTINUE
X ELSE IF (NSRC .EQ. 5) THEN
X DO 2400 IMRE = 1, 2
X DO 2200 IC = 1, 3
X DO 2000 ISC = 1, NSC
X PH(IMRE,IC,1,1,ISC) = PQ(IMRE,IC,1,2,ISC,IT)
X PH(IMRE,IC,2,1,ISC) = PQ(IMRE,IC,2,2,ISC,IT)
X PH(IMRE,IC,1,2,ISC) = PQ(IMRE,IC,1,1,ISC,IT)
X PH(IMRE,IC,2,2,ISC) = PQ(IMRE,IC,2,1,ISC,IT)
X 2000 CONTINUE
X 2200 CONTINUE
X 2400 CONTINUE
X ENDIF
X IF (IT.NE.1 .AND. ISELC.EQ.0) GO TO 5400
X DO 3400 IMRE = 1, 2
X DO 3200 IC = 1, NC
X DO 3000 MUS = 1, 2
X DO 2800 MUG = 1, 2
X DO 2600 ISC = 1, NSC
X PN(IMRE,IC,MUS,MUG,ISC) = 0.
X 2600 CONTINUE
X 2800 CONTINUE
X 3000 CONTINUE
X 3200 CONTINUE
X 3400 CONTINUE
X ISELC = 0
X DO 5200 IS = 1, 4
X IF (ISLECT(IS) .EQ. 1) THEN
X DO 3800 IC = 1, NC
X DO 3600 ISC = 1, NSC
X PN(1,IC,1,1,ISC) = PN(1,IC,1,1,ISC) + PH(2,IC,2,2,ISC)
X PN(2,IC,1,1,ISC) = PN(2,IC,1,1,ISC) - PH(1,IC,2,2,ISC)
X PN(1,IC,2,1,ISC) = PN(1,IC,2,1,ISC) + PH(2,IC,1,2,ISC)
X PN(2,IC,2,1,ISC) = PN(2,IC,2,1,ISC) - PH(1,IC,1,2,ISC)
X PN(1,IC,1,2,ISC) = PN(1,IC,1,2,ISC) - PH(2,IC,2,1,ISC)
X PN(2,IC,1,2,ISC) = PN(2,IC,1,2,ISC) + PH(1,IC,2,1,ISC)
X PN(1,IC,2,2,ISC) = PN(1,IC,2,2,ISC) - PH(2,IC,1,1,ISC)
X PN(2,IC,2,2,ISC) = PN(2,IC,2,2,ISC) + PH(1,IC,1,1,ISC)
X 3600 CONTINUE
X 3800 CONTINUE
X ISELC = ISELC + 1
X ELSE IF (ISLECT(IS) .EQ. 2) THEN
X DO 4200 IC = 1, NC
X DO 4000 ISC = 1, NSC
X PN(1,IC,1,1,ISC) = PN(1,IC,1,1,ISC) - PH(1,IC,2,2,ISC)
X PN(2,IC,1,1,ISC) = PN(2,IC,1,1,ISC) - PH(2,IC,2,2,ISC)
X PN(1,IC,2,1,ISC) = PN(1,IC,2,1,ISC) + PH(1,IC,1,2,ISC)
X PN(2,IC,2,1,ISC) = PN(2,IC,2,1,ISC) + PH(2,IC,1,2,ISC)
X PN(1,IC,1,2,ISC) = PN(1,IC,1,2,ISC) + PH(1,IC,2,1,ISC)
X PN(2,IC,1,2,ISC) = PN(2,IC,1,2,ISC) + PH(2,IC,2,1,ISC)
X PN(1,IC,2,2,ISC) = PN(1,IC,2,2,ISC) - PH(1,IC,1,1,ISC)
X PN(2,IC,2,2,ISC) = PN(2,IC,2,2,ISC) - PH(2,IC,1,1,ISC)
X 4000 CONTINUE
X 4200 CONTINUE
X ISELC = ISELC + 1
X ELSE IF (ISLECT(IS) .EQ. 3) THEN
X DO 4600 IC = 1, NC
X DO 4400 ISC = 1, NSC
X PN(1,IC,1,1,ISC) = PN(1,IC,1,1,ISC) + PH(2,IC,1,2,ISC)
X PN(2,IC,1,1,ISC) = PN(2,IC,1,1,ISC) - PH(1,IC,1,2,ISC)
X PN(1,IC,2,1,ISC) = PN(1,IC,2,1,ISC) - PH(2,IC,2,2,ISC)
X PN(2,IC,2,1,ISC) = PN(2,IC,2,1,ISC) + PH(1,IC,2,2,ISC)
X PN(1,IC,1,2,ISC) = PN(1,IC,1,2,ISC) - PH(2,IC,1,1,ISC)
X PN(2,IC,1,2,ISC) = PN(2,IC,1,2,ISC) + PH(1,IC,1,1,ISC)
X PN(1,IC,2,2,ISC) = PN(1,IC,2,2,ISC) + PH(2,IC,2,1,ISC)
X PN(2,IC,2,2,ISC) = PN(2,IC,2,2,ISC) - PH(1,IC,2,1,ISC)
X 4400 CONTINUE
X 4600 CONTINUE
X ISELC = ISELC + 1
X ELSE IF (ISLECT(IS) .EQ. 4) THEN
X DO 5000 IC = 1, NC
X DO 4800 ISC = 1, NSC
X PN(1,IC,1,1,ISC) = PN(1,IC,1,1,ISC) - PH(1,IC,1,1,ISC)
X PN(2,IC,1,1,ISC) = PN(2,IC,1,1,ISC) - PH(2,IC,1,1,ISC)
X PN(1,IC,2,1,ISC) = PN(1,IC,2,1,ISC) - PH(1,IC,2,1,ISC)
X PN(2,IC,2,1,ISC) = PN(2,IC,2,1,ISC) - PH(2,IC,2,1,ISC)
X PN(1,IC,1,2,ISC) = PN(1,IC,1,2,ISC) + PH(1,IC,1,2,ISC)
X PN(2,IC,1,2,ISC) = PN(2,IC,1,2,ISC) + PH(2,IC,1,2,ISC)
X PN(1,IC,2,2,ISC) = PN(1,IC,2,2,ISC) + PH(1,IC,2,2,ISC)
X PN(2,IC,2,2,ISC) = PN(2,IC,2,2,ISC) + PH(2,IC,2,2,ISC)
X 4800 CONTINUE
X 5000 CONTINUE
X ISELC = ISELC + 1
X ENDIF
X 5200 CONTINUE
X 5400 CONTINUE
X IF (ISELC .EQ. 0) THEN
X DO 5600 IALL = 1, 8*NC*NSC
X PN(IALL,1,1,1,1) = PH(IALL,1,1,1,1)
X 5600 CONTINUE
X ENDIF
X DO 6400 IZ = 1, ISIZE1
X DO 6200 IY = 1, ISIZE1
X DO 6000 IX = 1, NN1
X J0 = MOD(IY+IZ+IT+IPAR,2)
X J1 = 1 - J0
X DO 5800 I = 1, NC8
X XX(I,IX,IY,IZ,IT) = PNS(I,2*IX-J0,IY,IZ)
X PP(I,IX,IY,IZ,IT) = PNS(I,2*IX-J1,IY,IZ)
X 5800 CONTINUE
X 6000 CONTINUE
X 6200 CONTINUE
X 6400 CONTINUE
X 6600 CONTINUE
X DO 6800 I = 1, NN48
X RX(I) = B0*RX(I) - RQ(I)
X 6800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB011
X PARAMETER (N=1000)
X COMMON /DATA/ B(N), A(N,N)
X DO 1200 I = 2, N
X SUM = 0.
X DO 1000 L = 1, I - 1
X SUM = SUM + A(L,I)*B(L)
X 1000 CONTINUE
X B(I) = B(I) - SUM
X 1200 CONTINUE
X
X NRMAND = (N-1)*1
X IF (NRMAND .EQ. 0) THEN
X
X DO 1600 J = 1, N - 1, 2
X B(J+1) = B(J+1) - A(J,J+1)*B(J)
X DO 1400 I = J + 2, N
X B(I) = B(I) - A(J,I)*B(J) - A(J+1,I)*B(J+1)
X 1400 CONTINUE
X 1600 CONTINUE
X ELSE
X
X DO 1800 I = 2, N
X B(I) = B(I) - A(1,I)*B(1)
X 1800 CONTINUE
X
X DO 2200 J = 2, N - 1, 2
X B(J+1) = B(J+1) - A(J,J+1)*B(J)
X DO 2000 I = J + 2, N
X B(I) = B(I) - A(J,I)*B(J) - A(J+1,I)*B(J+1)
X 2000 CONTINUE
X 2200 CONTINUE
X
X ENDIF
X
X K = 1
X DO 2400 I = 1, N
X B(I) = B(I)*A(I,I)
X B(I) = B(I)*A(K,1)
X K = K + N + 1
X 2400 CONTINUE
X DO 2800 I = N - 1, 1, -1
X SUM = 0.
X DO 2600 L = I + 1, N
X SUM = SUM + A(I,L)*B(L)
X 2600 CONTINUE
X B(I) = B(I) - SUM
X 2800 CONTINUE
C
X IF (NRMAND .EQ. 0) THEN
X
X DO 3200 J = N, 2, -2
X B(J-1) = B(J-1) - A(J-1,J)*B(J)
X DO 3000 I = J - 2, 1, -1
X B(I) = B(I) - A(I,J)*B(J) - A(I,J-1)*B(J-1)
X 3000 CONTINUE
X 3200 CONTINUE
X
X ELSE
X
X DO 3400 I = N - 1, 1, -1
X B(I) = B(I) - A(I,N)*B(N)
X 3400 CONTINUE
X
X DO 3800 J = N - 1, 2, -2
X B(J-1) = B(J-1) - A(J-1,J)*B(J)
X DO 3600 I = J - 2, 1, -1
X B(I) = B(I) - A(I,J)*B(J) - A(I,J-1)*B(J-1)
X 3600 CONTINUE
X 3800 CONTINUE
X
X ENDIF
X
X
X RETURN
X END
X SUBROUTINE SUB012(B)
X PARAMETER (IDA=100,M=100,N=25,NRHS=100,IDB=100,NMAT=100)
X COMMON/DATA/ A(0:IDA, -M:0, 0:N),EPSS(0:256)
X DIMENSION B(0:NRHS, 0:IDB, 0:N)
X DATA EPS/1E-13/
X
X DO 2600 J = 0, N
X I0 = MAX((-M),(-J))
X
X DO 1600 I = I0, -1
X DO 1200 JJ = I0 - I, -1
X DO 1000 L = 0, NMAT
X A(L,I,J) = A(L,I,J) - A(L,JJ,I+J)*A(L,I+JJ,J)
X 1000 CONTINUE
X 1200 CONTINUE
X DO 1400 L = 0, NMAT
X A(L,I,J) = A(L,I,J)*A(L,0,I+J)
X 1400 CONTINUE
X 1600 CONTINUE
X
X DO 1800 L = 0, NMAT
X EPSS(L) = EPS*A(L,0,J)
X 1800 CONTINUE
X DO 2200 JJ = I0, -1
X DO 2000 L = 0, NMAT
X A(L,0,J) = A(L,0,J) - A(L,JJ,J)**2
X 2000 CONTINUE
X 2200 CONTINUE
X DO 2400 L = 0, NMAT
X A(L,0,J) = 1./SQRT(ABS(EPSS(L)+A(L,0,J)))
X 2400 CONTINUE
X 2600 CONTINUE
X
X DO 4400 I = 0, NRHS
X DO 3400 K = 0, N
X DO 2800 L = 0, NMAT
X B(I,L,K) = B(I,L,K)*A(L,0,K)
X 2800 CONTINUE
X DO 3200 JJ = 1, MIN(M,N-K)
X DO 3000 L = 0, NMAT
X B(I,L,K+JJ) = B(I,L,K+JJ) - A(L,(-JJ),K+JJ)*B(I,L,K)
X 3000 CONTINUE
X 3200 CONTINUE
X 3400 CONTINUE
X
X DO 4200 K = N, 0, -1
X DO 3600 L = 0, NMAT
X B(I,L,K) = B(I,L,K)*A(L,0,K)
X 3600 CONTINUE
X DO 4000 JJ = 1, MIN(M,K)
X DO 3800 L = 0, NMAT
X B(I,L,K-JJ) = B(I,L,K-JJ) - A(L,(-JJ),K)*B(I,L,K)
X 3800 CONTINUE
X 4000 CONTINUE
X 4200 CONTINUE
X 4400 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB013
X PARAMETER (IMAX=1000,KMAX=100)
X COMMON /DATA/ GESHEM( IMAX )
X COMMON /DATA/ PS( IMAX ),DEL( IMAX ),SL( IMAX ),
X 1QN( IMAX , KMAX ),QN1( IMAX , KMAX ),DQ( IMAX , KMAX ),
X 2TN1( IMAX , KMAX )
X COMMON /DATA/ ACUM( IMAX ),PRESS( KMAX ),TIN( KMAX ),QIN( KMAX ),
X 1TMST( KMAX ),QMST( KMAX ),DTKUO( KMAX ),DQKUO( KMAX )
X 2,ESAT( KMAX )
X
X DT = 3.14
X ACUMT = 4.15
X NKUO = 0
X RELKUO = .2175
X MSTA = 0
X RDT = 1./DT
X CPOVL = 1005./2.5E+6
X RELEPS = RELKUO*0.622
X DO 1200 K = 1, KMAX
X DO 1000 I = 1, IMAX
X DQ(I,K) = QN1(I,K) - QN(I,K)
X 1000 CONTINUE
X 1200 CONTINUE
X KACUM = 4
X DO 1400 I = 1, IMAX
X ACUM(I) = ACUMT*0.1
X 1400 CONTINUE
X DO 1800 K = 1, KMAX
X DO 1600 I = 1, IMAX
X ACUM(I) = ACUM(I) + RDT*DQ(I,K)*DEL(K)
X 1600 CONTINUE
X 1800 CONTINUE
X DO 4200 I = 1, IMAX
X DO 2000 K = 1, KMAX
X PRESS(K) = SL(K)*PS(I)
X 2000 CONTINUE
X DO 2200 K = 1, KMAX
X TIN(K) = TN1(I,K)
X QIN(K) = QN1(I,K)
X IF (QN1(I,K) .LT. .0) QIN(K) = .0
X 2200 CONTINUE
X QSATK = .65*.622*ESAT(1)/(PRESS(1)-0.378*ESAT(1))
X QDEF = QIN(1) - QSATK
X TIN(1) = TIN(1) + .25*(TIN(2)-TIN(1))
X HNEW = PS(I)/100.
X DO 2400 K = 2, KMAX
X X = TMST(K) - TIN(K)
X 2400 CONTINUE
X NKUO = NKUO + 1
X WATER = 0.
X WATER = WATER + DQ(I,1)*DEL(1)
X WATER = WATER + DQ(I,2)*DEL(2)
X Q1 = 0.
X Q2 = 0.
X DO 3000 K = 2, KMAX
X X = QMST(K) - QIN(K)
X IF (X .LE. 0) GO TO 2600
X Q1 = Q1 + X*DEL(K)
X 2600 CONTINUE
X X = TMST(K) - TIN(K)
X IF (X .LE. 0) GO TO 2800
X Q2 = Q2 + X*DEL(K)
X 2800 CONTINUE
X 3000 CONTINUE
X Q2 = Q2*CPOVL
X QEFF = .92
X IF (Q1.GT.0 .OR. Q2.GT.0) QEFF = WATER/(Q1+Q2)
X QEFF = AMIN1(1.00,QEFF)
X 3200 CONTINUE
X DTKUO(K) = X
X X = QEFF*(QMST(K)-QIN(K))
X IF (X .GT. 0) GO TO 3400
X X = 0.
X 3400 CONTINUE
X DQKUO(K) = X
X 3600 CONTINUE
X DTKUO(1) = 0.
X DQKUO(1) = 0.
X CEVAP = 0.
X DO 3800 K = 2, KMAX
X TIN(K) = TIN(K) + DTKUO(K)
X QIN(K) = DQKUO(K) + QIN(K)
X CEVAP = CEVAP + DQKUO(K)*DEL(K)
X 3800 CONTINUE
X FALL = WATER - CEVAP
X GESHEM(I) = GESHEM(I) + PS(I)*FALL/9.8
X QIN(1) = QIN(1) - DQ(I,1)
X IF (DQ(I,2) .GT. 0.) QIN(2) = QIN(2) - DQ(I,2)
X TIN(1) = TN1(I,1)
X DO 4000 K = 1, KMAX
X QN1(I,K) = QIN(K)
X TN1(I,K) = TIN(K)
X 4000 CONTINUE
X 4200 CONTINUE
X RETURN
X END
X SUBROUTINE SUB014
X PARAMETER (NI=48,NJ=72,NK=32,NJK=NJ*NK,DTH=1./NJ,DPH=1./NK
X $ ,DS=1./NI,DTDP=DTH*DPH,DVOL=DS*DTDP,TSI=NI,TDS=.5*TSI
X $ ,MLMNV=50,MLMNB=160,NMIN=-4,NMAX=4,MM=18,QN=1.00,QB=0.0
X $ ,NSTA=4,DSTA=2.*DTDP/NSTA,MLMNS=32,MMS=15,INSOL=0
X $ ,IVAC=0,PVAC=1.00,NVI=NI+IVAC
X $ ,NSMIN=-9,NSMAX=13,NJKS=NJK*NSTA,NPROCS=1,QONAX=9.99
X $ ,NSKIP=1,FSCALE=1.7,FXIN=5.0,PSHIFT=1.0,PARFAC=0.5 )
X
X PARAMETER (MD=MLMNS,MDY=MLMNS,ND=NVI,ND1=ND+1,NA=(MD+MDY)*ND+MD)
X
X PARAMETER(LMNB=160)
X COMMON /DATA/BS(NJK,0:NI),TCOS(NJK,MLMNB),TSIN(NJK,MLMNB)
X $ ,VJAC(NJK,0:NI)
X COMMON /DATA/ FPHV (MLMNB,NI)
X $ ,FBJAC(MLMNB,0:NI), FBS(MLMNB,0:NI)
X COMMON /DATA/ BJAC(NJK,0:NI),BJACS(NJK,0:NI)
X $ , GTTL(NJK,0:NI), GTPL(NJK,0:NI)
X $ , GPPL(NJK,0:NI)
X COMMON /DATA/ BT(NJK,0:NI), BP(NJK,0:NI), BSQ(NJK,0:NI)
X COMMON /DATA/ AM( NI), PTH( NI), PVP( NI),PVPI( NI)
X $ , FPP( NI), FTP( NI), PPI( NI), PP( NI)
X $ , FPPP( NI), FTPP( NI),AIOTA( NI), VVP( NI)
X $ , WMAGV( NI), WMAG( NI)
X $ , CIV( NI), CJV( NI), CIVP( NI),CJVP( NI)
X $ , CI ( NI), CJ ( NI), CIP ( NI),CJP ( NI)
X $ , CIPI( NI), CJPI( NI)
X $ , VP ( NI), VPP( NI),EQUIV( NI),EQUI( NI)
X LVMTPR = 1
X LCURR = 1
X DO 1400 I = 1, NI
X CI(I) = 0.
X CJ(I) = 0.
X VP(I) = 0.
X WMAG(I) = 0.
X DO 1000 JK = 1, NJK
X BP(JK,I) = GPPL(JK,I)*FTP(I) + GTPL(JK,I)*FPP(I)
X BT(JK,I) = GTPL(JK,I)*FTP(I) + GTTL(JK,I)*FPP(I)
X IF (LCURR .EQ. 1) THEN
X CI(I) = CI(I) - DTDP*BP(JK,I)
X CJ(I) = CJ(I) + DTDP*BT(JK,I)
X ENDIF
X IF (LCURR .EQ. 2) THEN
X CI(I) = CIV(I)
X CJ(I) = CJV(I)
X ENDIF
X FPP(I) = FPP(I)
X VP(I) = VP(I) - DTDP*BJAC(JK,I)
X 1000 CONTINUE
X DO 1200 JK = 1, NJK
X WMAG(I) = WMAG(I) + 0.5*BSQ(JK,I)*BJAC(JK,I)*DVOL
X 1200 CONTINUE
X 1400 CONTINUE
X DO 1600 I = 1, NI - 1
X VPI = 0.5*(VP(I+1)+VP(I))
X FTPI = 0.5*(FTP(I+1)+FTP(I))
X FPPI = 0.5*(FPP(I+1)+FPP(I))
X CIPI(I) = TSI*(CI(I+1)-CI(I))
X CJPI(I) = TSI*(CJ(I+1)-CJ(I))
X PVPI(I) = TSI*(PTH(I+1)-PTH(I))
X EQUIN = ABS(CJPI(I)*FPPI) + ABS(CIPI(I)*FTPI) + ABS(VPI*PVPI(I))
X EQUI(I) = ((CJPI(I)*FPPI-CIPI(I)*FTPI)-VPI*PVPI(I))/EQUIN
X PPI(I) = (CJPI(I)*FPPI-CIPI(I)*FTPI)/VPI
X 1600 CONTINUE
X DO 2000 I = 2, NI - 1
X FPPP(I) = TDS*(FPP(I+1)-FPP(I-1))
X FTPP(I) = TDS*(FTP(I+1)-FTP(I-1))
X PP(I) = 0.5*(PPI(I)+PPI(I-1))
X CIP(I) = 0.5*(CIPI(I)+CIPI(I-1))
X CJP(I) = 0.5*(CJPI(I)+CJPI(I-1))
X DO 1800 JK = 1, NJK
X BJACS(JK,I) = TDS*(BJAC(JK,I+1)-BJAC(JK,I-1))
X 1800 CONTINUE
X 2000 CONTINUE
X FTPP(NI) = 2.0*FTPP(NI-1) - FTPP(NI-2)
X FPPP(NI) = 2.0*FPPP(NI-1) - FPPP(NI-2)
X PP(NI) = 1.5*PPI(NI-1) - PPI(NI-2)*0.5
X CIP(NI) = 1.5*CIPI(NI-1) - CIPI(NI-2)*0.5
X CJP(NI) = 1.5*CJPI(NI-1) - CJPI(NI-2)*0.5
X FTPP(1) = 2.0*FTPP(2) - FTPP(3)
X FPPP(1) = 2.0*FPPP(2) - FPPP(3)
X PP(1) = 1.5*PPI(1) - PPI(2)*0.5
X CIP(1) = 1.5*CIPI(1) - CIPI(2)*0.5
X CJP(1) = 1.5*CJPI(1) - CJPI(2)*0.5
X DO 2200 JK = 1, NJK
X BJACS(JK,1) = 2.0*BJACS(JK,2) - BJACS(JK,3)
X BJACS(JK,NI) = 2.0*BJACS(JK,NI-1) - BJACS(JK,NI-2)
X 2200 CONTINUE
X DO 3600 I = 1, NI
X DO 2400 JK = 1, NJK
X VJAC(JK,I) = (FPP(I)*CJ(I)-FTP(I)*CI(I))/BSQ(JK,I)
X 2400 CONTINUE
X DO 2800 L = 1, LMNB
X FPHV(L,I) = 0.
X FBS(L,I) = 0.
X DO 2600 JK = 1, NJK
X FPHV(L,I) = FPHV(L,I) + VJAC(JK,I)*TCOS(JK,L)
X 2600 CONTINUE
X FPHV(L,I) = 2.*DTDP*FPHV(L,I)
X DIFJAC = 2.*(FBJAC(L,I)-FPHV(L,I))/(VP(I)+VVP(I))
X IF (ABS(DIFJAC).GE.1.E-06 .AND. LVMTPR.EQ.1) THEN
X ENDIF
X 2800 CONTINUE
X DO 3000 JK = 1, NJK
X BS(JK,I) = 0.
X 3000 CONTINUE
X DO 3400 L = 1, LMNB
X DO 3200 JK = 1, NJK
X BS(JK,I) = BS(JK,I) + FBS(L,I)*TSIN(JK,L)
X 3200 CONTINUE
X 3400 CONTINUE
X 3600 CONTINUE
X DO 3800 JK = 1, NJK
X BS(JK,1) = 2.*BS(JK,2) - BS(JK,3)
X 3800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB015(FX,JSAVE,KC)
X PARAMETER (NOMOL=172,NATOMS=3,M=10000)
X PARAMETER (NMOL=172,NATOM=3,NMOL1=171,NATMO=1)
X PARAMETER (MAX = NOMOL*NATOM,MXCPUS=8,NCPUS=8)
X COMMON /DATA/ TEMP,RHO,TSTEP,BOXL,BOXH,CUTOFF,CUT2
X COMMON /DATA/ OMAS,HMAS,WTMOL,ROH,ANGLE,FHM,FOM,ROHI,ROHI2
X COMMON /DATA/ QQ,A1,B1,A2,B2,A3,B3,A4,B4,AB1,AB2,AB3,AB4,C1,C2,
X * QQ2,QQ4,REF1,REF2,REF4
X COMMON /DATA/ UNITT,UNITL,UNITM,BOLTZ,AVGNO,PCC(10)
X COMMON /DATA/ X(M),Y(M),Z(M),FY(M),FZ(M),XM(M),YM(M),ZM(M)
X COMMON /DATA/ XL(NOMOL,14),YL(NOMOL,14),ZL(NOMOL,14),RL(NOMOL,14),
X . RS(NOMOL,14),FF(NOMOL,14),GG(NOMOL,14),FTEMP(NOMOL,4)
X COMMON /DATA/ VIRCPU(MXCPUS),FXT(MAX,MXCPUS),
X . FYT(MAX,MXCPUS),FZT(MAX,MXCPUS)
X DIMENSION FX(M),JSAVE(NOMOL),KC(NOMOL)
X FUNEXP(AB,B,XX) = AB*EXP(-B*XX)*XX
X IDCPU = 0
X VIR = 0
X DO 1200 ID = 1, NCPUS
X VIRCPU(ID) = 0.
X DO 1000 I = 1, MAX
X FXT(I,ID) = 0.
X FYT(I,ID) = 0.
X FZT(I,ID) = 0.
X 1000 CONTINUE
X 1200 CONTINUE
X
X
X IDCPU = IDCPU + 1
X IW10 = 1
X IWO0 = 2
X IW20 = 3
X
X DO 6400 I = 1, NMOL1
X
X
X IW1 = IW10 + (I-1)*NATOMS
X IWO = IWO0 + (I-1)*NATOMS
X IW2 = IW20 + (I-1)*NATOMS
X
X DO 1400 J = I + 1, NMOL
X
X JW1 = IW10 + (J-1)*NATOMS
X
X XL(J,1) = XM(I) - XM(J)
X XL(J,4) = X(IW1) - XM(J)
X XL(J,5) = X(IW1+2) - XM(J)
X XL(J,2) = XM(I) - X(JW1)
X XL(J,6) = X(IW1) - X(JW1)
X XL(J,8) = X(IW1+2) - X(JW1)
X XL(J,11) = X(IW1+1) - X(JW1)
X XL(J,10) = X(IW1+1) - X(JW1+1)
X XL(J,13) = X(IW1) - X(JW1+1)
X XL(J,14) = X(IW1+2) - X(JW1+1)
X XL(J,3) = XM(I) - X(JW1+2)
X XL(J,7) = X(IW1) - X(JW1+2)
X XL(J,9) = X(IW1+2) - X(JW1+2)
X XL(J,12) = X(IW1+1) - X(JW1+2)
X
X YL(J,1) = YM(I) - YM(J)
X YL(J,4) = Y(IW1) - YM(J)
X YL(J,5) = Y(IW1+2) - YM(J)
X YL(J,2) = YM(I) - Y(JW1)
X YL(J,6) = Y(IW1) - Y(JW1)
X YL(J,8) = Y(IW1+2) - Y(JW1)
X YL(J,11) = Y(IW1+1) - Y(JW1)
X YL(J,10) = Y(IW1+1) - Y(JW1+1)
X YL(J,13) = Y(IW1) - Y(JW1+1)
X YL(J,14) = Y(IW1+2) - Y(JW1+1)
X YL(J,3) = YM(I) - Y(JW1+2)
X YL(J,7) = Y(IW1) - Y(JW1+2)
X YL(J,9) = Y(IW1+2) - Y(JW1+2)
X YL(J,12) = Y(IW1+1) - Y(JW1+2)
X
X ZL(J,1) = ZM(I) - ZM(J)
X ZL(J,4) = Z(IW1) - ZM(J)
X ZL(J,5) = Z(IW1+2) - ZM(J)
X ZL(J,2) = ZM(I) - Z(JW1)
X ZL(J,8) = Z(IW1+2) - Z(JW1)
X ZL(J,6) = Z(IW1) - Z(JW1)
X ZL(J,11) = Z(IW1+1) - Z(JW1)
X ZL(J,10) = Z(IW1+1) - Z(JW1+1)
X ZL(J,13) = Z(IW1) - Z(JW1+1)
X ZL(J,14) = Z(IW1+2) - Z(JW1+1)
X ZL(J,3) = ZM(I) - Z(JW1+2)
X ZL(J,7) = Z(IW1) - Z(JW1+2)
X ZL(J,9) = Z(IW1+2) - Z(JW1+2)
X ZL(J,12) = Z(IW1+1) - Z(JW1+2)
X 1400 CONTINUE
X
X DO 1800 K = 1, 14
X DO 1600 J = I + 1, NMOL
X IF(ABS(XL(J,K)).GT.BOXH)XL(J,K)=XL(J,K)-SIGN(BOXL,XL(J,K))
X IF(ABS(YL(J,K)).GT.BOXH)YL(J,K)=YL(J,K)-SIGN(BOXL,YL(J,K))
X IF(ABS(ZL(J,K)).GT.BOXH)ZL(J,K)=ZL(J,K)-SIGN(BOXL,ZL(J,K))
X 1600 CONTINUE
X 1800 CONTINUE
X
X DO 2000 J = I + 1, NMOL
X KC(J) = 0
X 2000 CONTINUE
X
X DO 2400 K = 1, 9
X DO 2200 J = I + 1, NMOL
X RS(J,K)=XL(J,K)*XL(J,K)+YL(J,K)*YL(J,K)+ZL(J,K)*ZL(J,K)
X IF (RS(J,K) .GT. CUT2) KC(J) = KC(J) + 1
X 2200 CONTINUE
X 2400 CONTINUE
X
X JT = 0
X DO 2600 J = I + 1, NMOL
X IF (KC(J) .LT. 9) THEN
X JT = JT + 1
X JSAVE(JT) = J
X ENDIF
X 2600 CONTINUE
X JNUM = JT
X
X DO 3000 K = 1, 14
X DO 2800 J = I + 1, NMOL
X FF(J,K) = 0.
X 2800 CONTINUE
X 3000 CONTINUE
X
X DO 3200 J = I + 1, NMOL
X IF(RS(J,1).LT.CUT2)FF(J,1)=QQ4*(RS(J,1)*SQRT(RS(J,1)))+REF4
X IF (RS(J,2) .LT. CUT2) FF(J,2) = (-QQ2*(RS(J,2)*SQRT(RS(J,2)))
X 1 ) - REF2
X IF (RS(J,3) .LT. CUT2) FF(J,3) = (-QQ2*(RS(J,3)*SQRT(RS(J,3)))
X 1 ) - REF2
X IF (RS(J,4) .LT. CUT2) FF(J,4) = (-QQ2*(RS(J,4)*SQRT(RS(J,4)))
X 1 ) - REF2
X IF (RS(J,5) .LT. CUT2) FF(J,5) = (-QQ2*(RS(J,5)*SQRT(RS(J,5)))
X 1 ) - REF2
X IF (RS(J,6) .LE. CUT2) THEN
X RL(J,6) = SQRT(RS(J,6))
X FF(J,6) = QQ*(RS(J,6)*RL(J,6)) + REF1
X ENDIF
X IF (RS(J,7) .LE. CUT2) THEN
X RL(J,7) = SQRT(RS(J,7))
X FF(J,7) = QQ*(RS(J,7)*RL(J,7)) + REF1
X ENDIF
X IF (RS(J,8) .LE. CUT2) THEN
X RL(J,8) = SQRT(RS(J,8))
X FF(J,8) = QQ*(RS(J,8)*RL(J,8)) + REF1
X ENDIF
X IF (RS(J,9) .LE. CUT2) THEN
X RL(J,9) = SQRT(RS(J,9))
X FF(J,9) = QQ*(RS(J,9)*RL(J,9)) + REF1
X ENDIF
X 3200 CONTINUE
X
X DO 3400 J = I + 1, NMOL
X IF (KC(J) .LT. 9) VIRCPU(IDCPU) = VIRCPU(IDCPU) + FF(J,1)*RS(J
X 1 ,1) + FF(J,2)*RS(J,2) + FF(J,3)*RS(J,3) + FF(J,4)*RS(J,4)
X 2 + FF(J,5)*RS(J,5) + FF(J,6)*RS(J,6) + FF(J,7)*RS(J,7) + FF
X 3 (J,8)*RS(J,8) + FF(J,9)*RS(J,9)
X 3400 CONTINUE
X
X DO 3600 J = I + 1, NMOL
X IF (KC(J) .EQ. 0) THEN
X RS(J,10) = XL(J,10)*XL(J,10) + YL(J,10)*YL(J,10) + ZL(J,10
X 1 )*ZL(J,10)
X RL(J,10) = SQRT(RS(J,10))
X FF(J,10) = FUNEXP(AB1,B1,RL(J,10))
X
X FTEMP(J,1) = FUNEXP(AB2,B2,RL(J,6))
X FF(J,6) = FF(J,6) + FTEMP(J,1)
X RS(J,11) = XL(J,11)*XL(J,11) + YL(J,11)*YL(J,11) + ZL(J,11
X 1 )*ZL(J,11)
X RL(J,11) = SQRT(RS(J,11))
X FF(J,11)=FUNEXP(AB3,B3,RL(J,11))-FUNEXP(AB4,B4,RL(J,11))
X
X FTEMP(J,2) = FUNEXP(AB2,B2,RL(J,7))
X FF(J,7) = FF(J,7) + FTEMP(J,2)
X RS(J,12) = XL(J,12)*XL(J,12) + YL(J,12)*YL(J,12) + ZL(J,12
X 1 )*ZL(J,12)
X RL(J,12) = SQRT(RS(J,12))
X FF(J,12)=FUNEXP(AB3,B3,RL(J,12))-FUNEXP(AB4,B4,RL(J,12))
X
X FTEMP(J,3) = FUNEXP(AB2,B2,RL(J,8))
X FF(J,8) = FF(J,8) + FTEMP(J,3)
X RS(J,13) = XL(J,13)*XL(J,13) + YL(J,13)*YL(J,13) + ZL(J,13
X 1 )*ZL(J,13)
X RL(J,13) = SQRT(RS(J,13))
X FF(J,13)=FUNEXP(AB3,B3,RL(J,13))-FUNEXP(AB4,B4,RL(J,13))
X
X FTEMP(J,4) = FUNEXP(AB2,B2,RL(J,9))
X FF(J,9) = FF(J,9) + FTEMP(J,4)
X RS(J,14) = XL(J,14)*XL(J,14) + YL(J,14)*YL(J,14) + ZL(J,14
X 1 )*ZL(J,14)
X RL(J,14) = SQRT(RS(J,14))
X FF(J,14)=FUNEXP(AB3,B3,RL(J,14))-FUNEXP(AB4,B4,RL(J,14))
X ENDIF
X 3600 CONTINUE
X
X DO 3800 J = I + 1, NMOL
X IF (KC(J) .EQ. 0) VIRCPU(IDCPU) = VIRCPU(IDCPU) + FF(J,10)*RS(
X 1 J,10) + FTEMP(J,1)*RS(J,6) + FF(J,11)*RS(J,11) + FTEMP(J,2)
X 2 *RS(J,7) + FF(J,12)*RS(J,12) + FTEMP(J,3)*RS(J,8) + FF(J,13
X 3 )*RS(J,13) + FTEMP(J,4)*RS(J,9) + FF(J,14)*RS(J,14)
X 3800 CONTINUE
X
X DO 4200 K = 1, 14
X DO 4000 JS = 1, JNUM
X J = JSAVE(JS)
X GG(JS,K) = FF(J,K)*XL(J,K)
X 4000 CONTINUE
X 4200 CONTINUE
X
X DO 4400 JS = 1, JNUM
X J = JSAVE(JS)
X JW1 = IW10 + (J-1)*NATOMS
X JWO = IWO0 + (J-1)*NATOMS
X JW2 = IW20 + (J-1)*NATOMS
X G110 = GG(JS,10) + GG(JS,1)*C1
X G23 = GG(JS,2) + GG(JS,3)
X G45 = GG(JS,4) + GG(JS,5)
X FTEMP(JS,1) = G110 + GG(JS,11) + GG(JS,12) + C1*G23
X TT1 = GG(JS,1)*C2
X TT = G23*C2 + TT1
X FTEMP(JS,2) = GG(JS,6) + GG(JS,7) + GG(JS,13) + TT + GG(JS,4)
X FTEMP(JS,3) = GG(JS,8) + GG(JS,9) + GG(JS,14) + TT + GG(JS,5)
X TT = G45*C2 + TT1
X
X
X FXT(JWO,IDCPU)=FXT(JWO,IDCPU)-G110-GG(JS,13)-GG(JS,14)-C1*G45
X FXT(JW1,IDCPU) = FXT(JW1,IDCPU) - GG(JS,6) - GG(JS,8) - GG(JS,
X 1 11) - TT - GG(JS,2)
X FXT(JW2,IDCPU) = FXT(JW2,IDCPU) - GG(JS,7) - GG(JS,9) - GG(JS,
X 1 12) - TT - GG(JS,3)
X 4400 CONTINUE
X
X S1 = 0.
X S2 = 0.
X S3 = 0.
X DO 4600 JS = 1, JNUM
X S1 = S1 + FTEMP(JS,1)
X S2 = S2 + FTEMP(JS,2)
X S3 = S3 + FTEMP(JS,3)
X 4600 CONTINUE
X FX(IWO) = FX(IWO) + S1
X FX(IW1) = FX(IW1) + S2
X FX(IW2) = FX(IW2) + S3
X DO 5000 K = 1, 14
X DO 4800 JS = 1, JNUM
X J = JSAVE(JS)
X GG(JS,K) = FF(J,K)*YL(J,K)
X 4800 CONTINUE
X 5000 CONTINUE
X
X DO 5200 JS = 1, JNUM
X J = JSAVE(JS)
X JW1 = IW10 + (J-1)*NATOMS
X JWO = IWO0 + (J-1)*NATOMS
X JW2 = IW20 + (J-1)*NATOMS
X
X G110 = GG(JS,10) + GG(JS,1)*C1
X G23 = GG(JS,2) + GG(JS,3)
X G45 = GG(JS,4) + GG(JS,5)
X FTEMP(JS,1) = G110 + GG(JS,11) + GG(JS,12) + C1*G23
X TT1 = GG(JS,1)*C2
X TT = G23*C2 + TT1
X FTEMP(JS,2) = GG(JS,6) + GG(JS,7) + GG(JS,13) + TT + GG(JS,4)
X FTEMP(JS,3) = GG(JS,8) + GG(JS,9) + GG(JS,14) + TT + GG(JS,5)
X TT = G45*C2 + TT1
X FYT(JWO,IDCPU)=FYT(JWO,IDCPU)-G110-GG(JS,13)-GG(JS,14)-C1*G45
X FYT(JW1,IDCPU) = FYT(JW1,IDCPU) - GG(JS,6) - GG(JS,8) - GG(JS,
X 1 11) - TT - GG(JS,2)
X FYT(JW2,IDCPU) = FYT(JW2,IDCPU) - GG(JS,7) - GG(JS,9) - GG(JS,
X 1 12) - TT - GG(JS,3)
X 5200 CONTINUE
X
X S1 = 0.
X S2 = 0.
X S3 = 0.
X DO 5400 JS = 1, JNUM
X S1 = S1 + FTEMP(JS,1)
X S2 = S2 + FTEMP(JS,2)
X S3 = S3 + FTEMP(JS,3)
X 5400 CONTINUE
X FY(IWO) = FY(IWO) + S1
X FY(IW1) = FY(IW1) + S2
X FY(IW2) = FY(IW2) + S3
X
X DO 5800 K = 1, 14
X DO 5600 JS = 1, JNUM
X J = JSAVE(JS)
X GG(JS,K) = FF(J,K)*ZL(J,K)
X 5600 CONTINUE
X 5800 CONTINUE
X
X DO 6000 JS = 1, JNUM
X J = JSAVE(JS)
X JW1 = IW10 + (J-1)*NATOMS
X JWO = IWO0 + (J-1)*NATOMS
X JW2 = IW20 + (J-1)*NATOMS
X
X G110 = GG(JS,10) + GG(JS,1)*C1
X G23 = GG(JS,2) + GG(JS,3)
X G45 = GG(JS,4) + GG(JS,5)
X FTEMP(JS,1) = G110 + GG(JS,11) + GG(JS,12) + C1*G23
X TT1 = GG(JS,1)*C2
X TT = G23*C2 + TT1
X FTEMP(JS,2) = GG(JS,6) + GG(JS,7) + GG(JS,13) + TT + GG(JS,4)
X FTEMP(JS,3) = GG(JS,8) + GG(JS,9) + GG(JS,14) + TT + GG(JS,5)
X TT = G45*C2 + TT1
X FZT(JWO,IDCPU)=FZT(JWO,IDCPU)-G110-GG(JS,13)-GG(JS,14)-C1*G45
X FZT(JW1,IDCPU) = FZT(JW1,IDCPU) - GG(JS,6) - GG(JS,8) - GG(JS,
X 1 11) - TT - GG(JS,2)
X FZT(JW2,IDCPU) = FZT(JW2,IDCPU) - GG(JS,7) - GG(JS,9) - GG(JS,
X 1 12) - TT - GG(JS,3)
X 6000 CONTINUE
X
X S1 = 0.
X S2 = 0.
X S3 = 0.
X DO 6200 JS = 1, JNUM
X S1 = S1 + FTEMP(JS,1)
X S2 = S2 + FTEMP(JS,2)
X S3 = S3 + FTEMP(JS,3)
X 6200 CONTINUE
X FZ(IWO) = FZ(IWO) + S1
X FZ(IW1) = FZ(IW1) + S2
X FZ(IW2) = FZ(IW2) + S3
X
X 6400 CONTINUE
X DO 6800 ID = 1, NCPUS
X VIR = VIR + VIRCPU(ID)
X DO 6600 I = 1, MAX
X FX(I) = FX(I) + FXT(I,ID)
X 6600 CONTINUE
X 6800 CONTINUE
X DO 7200 ID = 1, NCPUS
X DO 7000 I = 1, MAX
X FY(I) = FY(I) + FYT(I,ID)
X 7000 CONTINUE
X 7200 CONTINUE
X DO 7600 ID = 1, NCPUS
X DO 7400 I = 1, MAX
X FZ(I) = FZ(I) + FZT(I,ID)
X 7400 CONTINUE
X 7600 CONTINUE
X DO 7800 I = 1, NATMO, NATOMS
X FX(I) = FX(I)*FHM
X FY(I) = FY(I)*FHM
X FZ(I) = FZ(I)*FHM
X FX(I+2) = FX(I+2)*FHM
X FY(I+2) = FY(I+2)*FHM
X FZ(I+2) = FZ(I+2)*FHM
X FX(I+1) = FX(I+1)*FOM
X FY(I+1) = FY(I+1)*FOM
X FZ(I+1) = FZ(I+1)*FOM
X 7800 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB016 (DATA,EX)
X
X COMMON/DATA/NPTS,NSKIP,MTRN,MSKIP,ISIGN,LOG,IXSHFT
C
X COMPLEX DATA(NPTS), EXK, EXJ, H, EX(1), FACT
X REAL HH(2)
X EQUIVALENCE (HH,H)
X
X IERR = 0
X HH(1) = 0
X HH(2) = 0
X FACT = (1.2349E-5,1.8567E-5)
X I2K = NPTS
X IF (I2K .EQ. 1) GO TO 4000
X SGN1 = ISIGN
X EXK = EX(1+IXSHFT)
X IF (SGN1 .LT. 0.) EXK = CONJG(EXK)
X 1000 CONTINUE
X I2KP = I2K
X I2K = I2K/2
X I2KS = I2K*NSKIP
X IF (2*I2K .NE. I2KP) GO TO 4000
X JLI = I2K/2 + 1
X DO 3000 JL = 1, I2K
X IF (JL - 1 .GT. 0) GO TO 1600
X EXJ = (1.,0.)
X DO 1400 JJ = JL, NPTS, I2KP
X DO 1200 MM = 1, MTRN
X JS = (JJ-1)*NSKIP + (MM-1)*MSKIP + 1
X H = DATA(JS) - DATA(JS+I2KS)
X DATA(JS) = (DATA(JS)+DATA(JS+I2KS))*FACT
X DATA(JS+I2KS) = H*FACT
X 1200 CONTINUE
X 1400 CONTINUE
X GO TO 2800
X 1600 CONTINUE
X IF (JL - JLI .EQ. 0) GO TO 2200
C
X EXJ = EXJ*EXK
X DO 2000 JJ = JL, NPTS, I2KP
X DO 1800 MM = 1, MTRN
X JS = (JJ-1)*NSKIP + (MM-1)*MSKIP + 1
X H = DATA(JS) - DATA(JS+I2KS)
X DATA(JS) = (DATA(JS)+DATA(JS+I2KS))*FACT
X DATA(JS+I2KS) = (H*EXJ)*FACT
X 1800 CONTINUE
X 2000 CONTINUE
X GO TO 2800
X 2200 CONTINUE
X EXJ = CMPLX(0.,SGN1)
X DO 2600 JJ = JL, NPTS, I2KP
X DO 2400 MM = 1, MTRN
X JS = (JJ-1)*NSKIP + (MM-1)*MSKIP + 1
X H = DATA(JS) - DATA(JS+I2KS)
X DATA(JS) = (DATA(JS)+DATA(JS+I2KS))*FACT
X DATA(JS+I2KS) = CMPLX((-SGN1*HH(2)),SGN1*HH(1))*FACT
X 2400 CONTINUE
X 2600 CONTINUE
X 2800 CONTINUE
X 3000 CONTINUE
C
X EXK = EXK*EXK
X IF (I2K - 1 .GT. 0) GO TO 1000
X IF (NPTS .LE. 2) GO TO 4000
X NPTSD2 = NPTS/2
X JMIN = 0
X JMAX = NPTS - 4
X JREV = 0
X DO 3800 J = JMIN, JMAX, 2
X I2K = NPTSD2
X JREV2 = JREV + I2K
X IF (JREV2 - (J+1) .LE. 0) GO TO 3600
X DO 3200 MM = 1, MTRN
X JREV2S = (MM-1)*MSKIP + JREV2*NSKIP
X JS = (MM-1)*MSKIP + (J+1)*NSKIP
X H = DATA(JREV2S+1)
X DATA(JREV2S+1) = DATA(JS+1)*FACT
X DATA(JS+1) = H*FACT
X 3200 CONTINUE
X IF (JREV - J .LE. 0) GO TO 3600
X DO 3400 MM = 1, MTRN
X JREVS = JREV*NSKIP + (MM-1)*MSKIP
X JS = J*NSKIP + (MM-1)*MSKIP
X H = DATA(JREVS+1)
X DATA(JREVS+1) = DATA(JS+1)*FACT
X DATA(JS+1) = H*FACT
X 3400 CONTINUE
X 3600 CONTINUE
X 3800 CONTINUE
C
X 4000 CONTINUE
C
X NFTVMT = NFTVMT + 1
C
X RETURN
X END
X SUBROUTINE SUB017
C
X PARAMETER (NNX=44)
X PARAMETER (NNY=44)
X PARAMETER (NNZ=4)
X PARAMETER (MXC=11)
X PARAMETER (MXP=3)
X PARAMETER (MXW=5)
X PARAMETER (NXYN=NNX*NNY)
X PARAMETER (NBL=NXYN*NNZ)
X PARAMETER (NBLW=NBL+MXW)
X PARAMETER (N=MXC)
X PARAMETER (NY=NNY)
X PARAMETER (NX=NNX)
X PARAMETER (NZ=NNZ)
X PARAMETER (NXM1=NX-1)
X PARAMETER (NWELL=5)
C ----------------------------------------------------------------
X COMMON /DATA/ CTOT(NBLW,MXC),C(NBLW,MXC,MXP)
X * ,CSE(NBLW),S(NBLW,MXP)
X COMMON /DATA/ BRK,CRK,VIS1,VIS2,AP1,AP2,AP3,GAMMAC,EPHI4,EPHI3,
X * GAMHF,SSLOPE,POWN,CSE1,ALPHA1,ALPHA2,ALPHA3,ALPHA4,ALPHA5,
X * BETAP
X COMMON /DATA/ VIS(NBL,MXP),RPERM(NBLW,MXP)
X *,PERMX(NBL),PERMY(NBL),PERMZ(NBL),
X *QI(MXW,MXP),QT(MXW,NNZ),Q(MXW,NNZ,MXP),PWF(MXW)
X COMMON /DATA/ EL(NBL),DX(NNX),DY(NNY),
X * DZ(NNZ)
X COMMON /DATA/ TRSX(NBL,MXP),TRSY(NBL,MXP),
X *TRSZ(NBL,MXP),TX(NBL),TY(NBL),
X *TZ(NBL),CONVX(NBL,MXC,MXP),CONVY(NBL,MXC,MXP),
X *CONVZ(NBL,MXC,MXP),VX(NBL,MXP),VY(NBL,MXP),
X *VZ(NBL,MXP)
X COMMON /DATA/ POR(NBL),RKF(NBL,MXP)
X COMMON /DATA/ RW(MXW),SWELL(MXW),PI(MXW,NNZ),TTM(NNZ),
X $ TM(MXW,NNZ),PTM(MXW,NNZ,MXP),GAMMAT(MXW,NNZ)
X COMMON /DATA/ C6JO(NBLW),C6ADSS(NBLW),
X * C6HATS(NBLW),QV,XKC,XKS,EQW
X COMMON /DATA/ CUMI(MXC),CUMP(MXC),OIP(MXC),
X * T,TINJ,ICNT,WHPV,PRF
X COMMON /DATA/FOREC,FOREC1,RESPV,RESATK(NNZ),BTO(MXW),
X * VB(NBL)
X COMMON /DATA/ TITLE(30),RELERR(MXC),SWI
X COMMON /DATA/ D(MXC,MXP),ALPHAL(MXP),ALPHAT(MXP)
X COMMON /DATA/ DCMAX,DISPC
X LOGICAL LWKSP1
X COMMON /DATA/ LWKSP1(NBL)
X COMMON /DATA/ COE1(NBLW),COE2(NBLW),COE3(NBLW),
X * COE4(NBLW),COE5(NBLW)
X COMMON /DATA/ COE6(NBLW),COE7(NBLW),COEX(NBLW),COEYU(NBLW),
X * COEZT(NBLW),DDX(NBLW),DDY(NBLW),DDZ(NBLW),
X * DC(NBLW)
X COMMON /DATA/ TK(3),TTRP(3),TREC(3),TBT(MXW,3),
X * RDC(3),TRD(3),RET(3)
X COMMON /DATA/ AG1,AG2,CRG,AGK,BGK
X COMMON /DATA/ A15D,B15D,C15DSS(NBL),C14DSS(NBL)
X * ,QW(NBL),TC14DS(NBL)
X COMMON /DATA/ AK1,AK2,SCR,GKIN(MXC),DT
C
X COMMON /INTS/ IPERM,IMES
X COMMON /INTS/ NGP,NGP1,NGP2,NGP3,NGP4,NG,IREACT,
X $ IW(MXW),JW(MXW),IJKW(MXW),KWELL(MXW,NNZ),ICF(MXC)
C
X DIMENSION OP(MXC),TEMP(MXC)
C
X IJK = 0
X DO 1400 K = 1, NZ
X DO 1200 J = 1, NY
X DO 1000 I = 1, NX
X IJK = IJK + 1
X DDX(IJK) = DX(I)
X DDY(IJK) = DY(J)
X DDZ(IJK) = DZ(K)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X IF (IMES .EQ. 2) DCMAX = 0.0
X DO 20000 KC = 1, N
X IF (ICF(KC) .EQ. 0) GO TO 19800
X EPHI1 = 1.0
X IF (KC .EQ. 3) EPHI1 = EPHI3
X IF (KC .EQ. 4) EPHI1 = EPHI4
X DO 1600 I = 1, NBL
X COEX(I) = 0.0
X COEYU(I) = 0.0
X COEZT(I) = 0.0
X 1600 CONTINUE
X DO 13200 L = 1, 3
X ALPHAX = ALPHAL(L) - ALPHAT(L)
C
X IF (NY .GT. 1) THEN
C
X DO 1800 I = NX + 1, NBL - NX
X COE1(I) = 0.25*(VY(I,L)+VY(I+1,L)+VY(I-NX,L)+VY(I+1-NX,L
X 1 ))
X 1800 CONTINUE
X DO 2400 K = 1, NZ
X IBGN = (K-1)*NXYN + 1
X IEND = IBGN + NXM1
X DO 2000 I = IBGN, IEND
X COE1(I) = 0.5*(VY(I,L)+VY(I+1,L))
X 2000 CONTINUE
X IBGN = K*NXYN - NXM1
X IEND = IBGN + NXM1
X DO 2200 I = IBGN, IEND
X COE1(I) = 0.5*(VY(I-NX,L)+VY(I-NX+1,L))
X 2200 CONTINUE
X 2400 CONTINUE
X ELSE
X DO 2600 I = 1, NBL
X COE1(I) = 0.0
X 2600 CONTINUE
X ENDIF
X IF (NZ .GT. 1) THEN
X DO 2800 I = 1, NXYN
X COE2(I) = 0.5*(VZ(I,L)+VZ(I+1,L))
X 2800 CONTINUE
X IBGN = (NZ-1)*NXYN + 1
X DO 3000 I = IBGN, NBL
X COE2(I) = 0.5*(VZ(I-NXYN,L)+VZ(I-NXYN+1,L))
X 3000 CONTINUE
X IF (NZ .GT. 2) THEN
X DO 3200 I = NXYN + 1, NBL - NXYN
X COE2(I) = 0.25*(VZ(I,L)+VZ(I+1,L)+VZ(I-NXYN,L)+VZ(I-
X 1 NXYN+1,L))
X 3200 CONTINUE
X ENDIF
X ELSE
X DO 3400 I = 1, NBL
X COE2(I) = 0.0
X 3400 CONTINUE
X ENDIF
X DO 3600 I = 1, NBL
X COE3(I) = VX(I,L)**2
X COE4(I) = COE1(I)**2
X COE5(I) = COE2(I)**2
X COE6(I) = SQRT(COE3(I)+COE4(I)+COE5(I))
X IF (COE6(I) .LE. .0001) COE6(I) = 1.E199
X
X COE6(I) = 1.0/COE6(I)
X 3600 CONTINUE
X DO 3800 I = 1, NBL - 1
X COE7(I) = 0.5*(S(I,L)*POR(I)+S(I+1,L)*POR(I+1))
X 3800 CONTINUE
C
X DO 4000 I = 1, NBL
X COE7(I) = COE7(I)*D(KC,L) + (ALPHAL(L)*COE3(I)+ALPHAT(L)*(
X 1 COE4(I)+COE5(I)))*COE6(I)
X COE1(I) = ALPHAX*ABS(COE1(I)*VX(I,L))*COE6(I)
X COE2(I) = ALPHAX*ABS(COE2(I)*VX(I,L))*COE6(I)
X 4000 CONTINUE
X DO 4200 I = 1, NBL - 1
X COE3(I) = 2.*(.5*DISPC*DDX(I)*ABS(VX(I,L))-COE7(I))*(C(I+1,
X 1 KC,L)-C(I,KC,L))/(DDX(I+1)+DDX(I))
X 4200 CONTINUE
X IF (NY .GT. 2) THEN
X DO 4400 I = NX + 1, NBL - NX - 1
X COE4(I) = 0.25*COE1(I)*(C(I+NX,KC,L)+C(I+NX+1,KC,L)-C(I-
X 1 NX,KC,L)-C(I-NX+1,KC,L))/DDY(I)
X 4400 CONTINUE
X DO 5000 K = 1, NZ
X IBGN = (K-1)*NXYN + 1
X IEND = IBGN + NXM1
X DO 4600 I = IBGN, IEND
X COE4(I) = 0.0
X 4600 CONTINUE
X IBGN = K*NXYN - NXM1
X IEND = IBGN + NXM1
X DO 4800 I = IBGN, IEND
X COE4(I) = 0.0
X 4800 CONTINUE
X 5000 CONTINUE
X ELSE
X DO 5200 I = 1, NBL
X COE4(I) = 0.0
X 5200 CONTINUE
X ENDIF
X DO 5400 I = 1, NBL
X COE5(I) = 0.0
X 5400 CONTINUE
X IF (NZ .GT. 2) THEN
X DO 5600 I = NXYN + 1, NBL - NXYN - 1
X COE5(I) = 0.25*COE2(I)*(C(I+NXYN,KC,L)+C(I+NXYN+1,KC,L)-
X 1 C(I-NXYN,KC,L)-C(I-NXYN+1,KC,L))/DDZ(I)
X 5600 CONTINUE
X ENDIF
C
X DO 5800 I = 1, NBL - 1
X COEX(I+1) = COEX(I+1) + COE3(I) - COE4(I) - COE5(I)
X 5800 CONTINUE
C
X IF (NY .GT. 1) THEN
C
X DO 6000 I = 2, NBL - NX
X COE1(I) = 0.25*(VX(I,L)+VX(I+NX,L)+VX(I-1,L)+VX(I+NXM1,L
X 1 ))
X 6000 CONTINUE
X DO 6200 I = 1, NBL - NX, NX
X COE1(I) = 0.5*(VX(I,L)+VX(I+NX,L))
X 6200 CONTINUE
X DO 6400 I = NX, NBL - NX, NX
X COE1(I) = 0.5*(VX(I-1,L)+VX(I-1+NX,L))
X 6400 CONTINUE
X IF (NZ .GT. 1) THEN
X DO 6600 I = 1, NXYN
X COE2(I) = 0.5*(VZ(I,L)+VZ(I+NX,L))
X 6600 CONTINUE
X DO 6800 I = (NZ-1)*NXYN + 1, NBL
X COE2(I) = 0.5*(VZ(I-NXYN,L)+VZ(I-NXYN+NX,L))
X 6800 CONTINUE
X IF (NZ .GT. 2) THEN
X DO 7000 I = NXYN + 1, (NZ-1)*NXYN
X COE2(I) = 0.25*(VZ(I,L)+VZ(I+NX,L)+VZ(I-NXYN,L)+
X 1 VZ(I-NXYN+NX,L))
X 7000 CONTINUE
X ENDIF
X ELSE
X DO 7200 I = 1, NBL
X COE2(I) = 0.0
X 7200 CONTINUE
X ENDIF
X DO 7400 I = 1, NBL
X COE3(I) = VY(I,L)**2
X COE4(I) = COE1(I)**2
X COE5(I) = COE2(I)**2
X COE6(I) = SQRT(COE3(I)+COE4(I)+COE5(I))
X IF (COE6(I) .LE. .0001) COE6(I) = 1.E199
X COE6(I) = 1.0/COE6(I)
X 7400 CONTINUE
X DO 7600 I = 1, NBL - NX
X COE7(I) = 0.5*(S(I,L)*POR(I)+S(I+NX,L)*POR(I+NX))
X 7600 CONTINUE
X DO 7800 I = 1, NBL
X COE7(I) = COE7(I)*D(KC,L) + (ALPHAL(L)*COE3(I)+ALPHAT(L)
X 1 *(COE4(I)+COE5(I)))*COE6(I)
X COE1(I) = ALPHAX*ABS(COE1(I)*VY(I,L))*COE6(I)
X COE2(I) = ALPHAX*ABS(COE2(I)*VY(I,L))*COE6(I)
X 7800 CONTINUE
C
X DO 8000 I = 1, NBL - NX
X COE3(I) = 2.*(.5*DISPC*DDY(I)*ABS(VY(I,L))-COE7(I))*(C(I
X 1 +NX,KC,L)-C(I,KC,L))/(DDY(I+NX)+DDY(I))
X 8000 CONTINUE
X DO 8200 I = 2, NBL - NX - 1
X COE4(I) = 0.25*COE1(I)*(C(I+1,KC,L)+C(I+1+NX,KC,L)-C(I-1
X 1 ,KC,L)-C(I-1+NX,KC,L))/DDX(I)
X 8200 CONTINUE
X DO 8400 I = 1, NBL, NX
X COE4(I) = 0.0
X 8400 CONTINUE
X DO 8600 I = NX, NBL, NX
X COE4(I) = 0.0
X 8600 CONTINUE
X DO 8800 I = 1, NBL
X COE5(I) = 0.0
X 8800 CONTINUE
X IF (NZ .GT. 2) THEN
X DO 9000 I = NXYN + 1, NBL - NXYN - NX
X COE5(I) = 0.25*COE2(I)*(C(I+NXYN,KC,L)+C(I+NXYN+NX,
X 1 KC,L)-C(I-NXYN,KC,L)-C(I-NXYN+NX,KC,L))/DDZ(I)
X 9000 CONTINUE
X ENDIF
C
X DO 9200 I = 1, NBL - NX
X COEYU(I+NX) = COEYU(I+NX) + COE3(I) - COE4(I) - COE5(I)
X 9200 CONTINUE
X ENDIF
C
X IF (NZ .GT. 1) THEN
C
X DO 9400 I = 2, NBL - NXYN
X COE1(I) = 0.25*(VX(I,L)+VX(I-1,L)+VX(I+NXYN,L)+VX(I+NXYN
X 1 -1,L))
X 9400 CONTINUE
X DO 9600 I = 1, NBL - NXYN, NX
X COE1(I) = 0.5*(VX(I,L)+VX(I+NXYN,L))
X 9600 CONTINUE
X DO 9800 I = NX, NBL - NXYN, NX
X COE1(I) = 0.5*(VX(I-1,L)+VX(I+NXYN-1,L))
X 9800 CONTINUE
X DO 10000 I = NX + 1, NBL - NXYN - NX
X COE2(I) = 0.25*(VY(I,L)+VY(I-NX,L)+VY(I+NXYN,L)+VY(I+
X 1 NXYN-NX,L))
X10000 CONTINUE
X DO 10600 K = 1, NZ - 1
X IBGN = (K-1)*NXYN + 1
X IEND = IBGN + NXM1
X DO 10200 I = IBGN, IEND
X COE2(I) = 0.5*(VY(I,L)+VY(I+NXYN,L))
X10200 CONTINUE
X IBGN = K*NXYN - NXM1
X IEND = IBGN + NXM1
X DO 10400 I = IBGN, IEND
X COE2(I) = 0.5*(VY(I-NX,L)+VY(I+NXYN-NX,L))
X10400 CONTINUE
X10600 CONTINUE
X DO 10800 I = 1, NBL - NXYN
X COE3(I) = VZ(I,L)**2
X COE4(I) = COE1(I)**2
X COE5(I) = COE2(I)**2
X COE6(I) = SQRT(COE3(I)+COE4(I)+COE5(I))
X IF (COE6(I) .LE. .0001) COE6(I) = 1.E199
X COE6(I) = 1.0/COE6(I)
X10800 CONTINUE
X DO 11000 I = 1, NBL - NXYN
X COE7(I) = 0.5*(S(I,L)*POR(I)+S(I+NXYN,L)*POR(I+NXYN))
X11000 CONTINUE
X DO 11200 I = 1, NBL - NXYN
X COE7(I) = COE7(I)*D(KC,L) + (ALPHAL(L)*COE3(I)+ALPHAT(L)
X 1 *(COE4(I)+COE5(I)))*COE6(I)
X COE1(I) = ALPHAX*ABS(COE1(I)*VZ(I,L))*COE6(I)
X COE2(I) = ALPHAX*ABS(COE2(I)*VZ(I,L))*COE6(I)
X11200 CONTINUE
C
X DO 11400 I = 1, NBL - NXYN
X COE3(I) = 2.*(.5*DISPC*DDZ(I)*ABS(VZ(I,L))-COE7(I))*(C(I
X 1 +NXYN,KC,L)-C(I,KC,L))/(DDZ(I+NXYN)+DDZ(I))
X11400 CONTINUE
X DO 11600 I = 2, NBL - NXYN - 1
X COE4(I) = 0.25*COE1(I)*(C(I+1,KC,L)+C(I+NXYN+1,KC,L)-C(I
X 1 -1,KC,L)-C(I+NXYN-1,KC,L))/DDX(I)
X11600 CONTINUE
X DO 11800 I = 1, NBL - NXYN, NX
X COE4(I) = 0.0
X11800 CONTINUE
X DO 12000 I = NX, NBL - NXYN, NX
X COE4(I) = 0.0
X12000 CONTINUE
X DO 12200 I = NX + 1, NBL - NXYN - NX
X COE5(I) = 0.25*COE2(I)*(C(I+NX,KC,L)+C(I+NX+NXYN,KC,L)-C
X 1 (I-NX,KC,L)-C(I+NXYN-NX,KC,L))/DDY(I)
X12200 CONTINUE
X DO 12800 K = 1, NZ - 1
X IBGN = (K-1)*NXYN + 1
X IEND = IBGN + NXM1
X DO 12400 I = IBGN, IEND
X COE5(I) = 0.0
X12400 CONTINUE
X IBGN = K*NXYN - NXM1
X IEND = IBGN + NXM1
X DO 12600 I = IBGN, IEND
X COE5(I) = 0.0
X12600 CONTINUE
X12800 CONTINUE
C
X DO 13000 I = 1, NBL - NXYN
X COEZT(I+NXYN)=COEZT(I+NXYN)+COE3(I)-COE4(I)-COE5(I)
X13000 CONTINUE
X ENDIF
X13200 CONTINUE
X DO 13400 I = 1, NBL, NX
X COEX(I) = 0.0
X13400 CONTINUE
X DO 13800 K = 1, NZ
X IBGN = (K-1)*NXYN + 1
X IEND = IBGN + NXM1
X DO 13600 I = IBGN, IEND
X COEYU(I) = 0.0
X13600 CONTINUE
X13800 CONTINUE
X DO 14000 I = 1, NXYN
X COEZT(I) = 0.0
X14000 CONTINUE
X DO 14200 I = 1, NBL
X CONVX(I,KC,1) = CONVX(I,KC,1) + CONVX(I,KC,2) + CONVX(I,KC,3)
X CONVY(I,KC,1) = CONVY(I,KC,1) + CONVY(I,KC,2) + CONVY(I,KC,3)
X CONVZ(I,KC,1) = CONVZ(I,KC,1) + CONVZ(I,KC,2) + CONVZ(I,KC,3)
X14200 CONTINUE
X DO 14400 I = 1, NBL
X COE4(I) = 0.0
X COE5(I) = 0.0
X14400 CONTINUE
X COE3(1) = (COEX(2)+CONVX(1,KC,1))/DDX(1)
X DO 14600 I = 2, NBL - 1
X COE3(I) = (COEX(I+1)-COEX(I)+CONVX(I,KC,1)-CONVX(I-1,KC,1))/
X 1 DDX(I)
X14600 CONTINUE
X COE3(NBL) = ((-COEX(NBL))+CONVX(NBL,KC,1)-CONVX(NBL-1,KC,1))/DDX
X 1 (NBL)
X IF (NY .GT. 1) THEN
X DO 14800 I = 1, NX
X COE4(I) = (COEYU(I+NX)+CONVY(I,KC,1))/DDY(I)
X14800 CONTINUE
X DO 15000 I = NX + 1, NBL - NX
X COE4(I) = (COEYU(I+NX)-COEYU(I)+CONVY(I,KC,1)-CONVY(I-NX,
X 1 KC,1))/DDY(I)
X15000 CONTINUE
X DO 15200 I = NBL - NX + 1, NBL
X COE4(I) = ((-COEYU(I))+CONVY(I,KC,1)-CONVY(I-NX,KC,1))/DDY
X 1 (I)
X15200 CONTINUE
X ENDIF
X IF (NZ .GT. 1) THEN
X IF (NZ .EQ. 2) THEN
X DO 15400 I = 1, NXYN
X COE5(I) = (COEZT(I+NXYN)+CONVZ(I,KC,1))/DDZ(I)
X15400 CONTINUE
X DO 15600 I = NXYN + 1, NBL
X COE5(I) = ((-COEZT(I))+CONVZ(I,KC,1)-CONVZ(I-NXYN,KC,1
X 1 ))/DDZ(I)
X15600 CONTINUE
X ELSE
X DO 15800 I = NXYN + 1, NBL - NXYN
X COE5(I) = (COEZT(I+NXYN)-COEZT(I)+CONVZ(I,KC,1)-CONVZ(
X 1 I-NXYN,KC,1))/DDZ(I)
X15800 CONTINUE
X DO 16000 I = NBL - NXYN + 1, NBL
X COE5(I) = ((-COEZT(I))+CONVZ(I,KC,1)-CONVZ(I-NXYN,KC,1
X 1 ))/DDZ(I)
X16000 CONTINUE
X ENDIF
X ENDIF
C
X IF (KC .GT. 8) THEN
X IT = KC - 8
X IF (RET(IT) .NE. 0.) THEN
X DO 16200 I = 1, NBL
X CON = 1./(1.+RET(IT)/S(I,1))
X COE3(I) = COE3(I)*CON
X COE4(I) = COE4(I)*CON
X COE5(I) = COE5(I)*CON
X16200 CONTINUE
X ENDIF
X ENDIF
X DO 16400 I = 1, NBL
X DC(I) = (-DT/EPHI1)*(COE3(I)+COE4(I)+COE5(I))/POR(I)
X16400 CONTINUE
C
X DO 17000 M = 1, NWELL
X I = IW(M)
X J = JW(M)
X DO 16800 K = 1, NZ
X IJK1 = (K-1)*NXYN + (J-1)*NX + I
X DO 16600 L = 1, 3
X IF (Q(M,K,L) .GT. 0.0) THEN
X CW = C(IJKW(M),KC,L)
X CUMI(KC) = CUMI(KC) + Q(M,K,L)*CW*DT
X ELSE
X CW = C(IJK1,KC,L)
X IF (NY .NE. 1) THEN
X TERM0 = 28.*CW
X TERM1 = CW
X IF (J .NE. 1) TERM1 = C(IJK1-NX,KC,L)
X TERM2 = CW
X IF (I .NE. 1) TERM2 = C(IJK1-1,KC,L)
X TERM3 = CW
X IF (I .NE. NX) TERM3 = C(IJK1+1,KC,L)
X TERM4 = CW
X IF (J .NE. NY) TERM4 = C(IJK1+NX,KC,L)
X CW = (TERM0-TERM1-TERM2-TERM3-TERM4)/24.
X ENDIF
X CUMP(KC) = CUMP(KC) + Q(M,K,L)*CW*DT
X ENDIF
X DC(IJK1) = DC(IJK1) + (DT*CW/EPHI1)*Q(M,K,L)/VB(IJK1)
X16600 CONTINUE
X16800 CONTINUE
X17000 CONTINUE
C
X IF (KC .GT. 8) THEN
X KCT = KC - 8
X CONS = RDC(KCT)*DT
X IF (CONS .EQ. 0.0) GO TO 18000
X DO 17200 I = 1, NBL
X COE1(I) = 0.0
X17200 CONTINUE
X DO 17600 L = 1, 3
X DO 17400 I = 1, NBL
X COE1(I) = COE1(I) + CONS*C(I,KC,L)
X17400 CONTINUE
X17600 CONTINUE
X TR = 0.0
X DO 17800 I = 1, NBL
X DC(I) = DC(I) - COE1(I)
X TR = TR + COE1(I)*VB(I)
X17800 CONTINUE
X TRD(KCT) = TRD(KCT) + TR
X18000 CONTINUE
X ENDIF
C
X IF (IREACT.EQ.1 .AND. NG.NE.0) THEN
X IF (KC .EQ. 4) THEN
X DO 18200 I = 1, NBL
X COE1(I) = DT*(1./(SCR+1.))*AK2*1.E12*(C(I,NGP3,1)*
X 1 1.E-4*C(I,4,1))**2
X DC(I) = DC(I) - COE1(I)
X GKIN(4) = GKIN(4) + COE1(I)*VB(I)
X18200 CONTINUE
X ELSE IF (KC .EQ. NGP1) THEN
X DO 18400 I = 1, NBL
X COE1(I) = DT*AK1*C(I,NGP1,1)*C(I,NGP2,1)
X DC(I) = DC(I) - COE1(I)
X GKIN(NGP1) = GKIN(NGP1) + COE1(I)*VB(I)
X18400 CONTINUE
X ELSE IF (KC .EQ. NGP2) THEN
X DO 18600 I = 1, NBL
X COE1(I) = DT*AK1*2.111*C(I,NGP1,1)*C(I,NGP2,1)
X DC(I) = DC(I) - COE1(I)
X GKIN(NGP2) = GKIN(NGP2) + COE1(I)*VB(I)
X18600 CONTINUE
X ELSE IF (KC .EQ. NGP3) THEN
X DO 18800 I = 1, NBL
X COE1(I) = DT*(0.48*AK1*C(I,NGP1,1)*C(I,NGP2,1)-AK2*(
X 1 SCR/(SCR+1.))*(C(I,4,1)*C(I,NGP3,1)*1.E4)**2)
X DC(I) = DC(I) + COE1(I)
X GKIN(NGP3) = GKIN(NGP3) + COE1(I)*VB(I)
X18800 CONTINUE
X ELSE IF (KC .EQ. NGP4) THEN
X DO 19000 I = 1, NBL
X COE1(I) = DT*AK2*(C(I,NGP3,1)*C(I,4,1)*1.E4)**2
X DC(I) = DC(I) + COE1(I)
X GKIN(NGP4) = GKIN(NGP4) + COE1(I)*VB(I)
X19000 CONTINUE
X ENDIF
X ENDIF
X DO 19200 I = 1, NBL
X CTOT(I,KC) = CTOT(I,KC) + DC(I)
X19200 CONTINUE
X IF (KC.LE.3 .AND. IMES.EQ.2) THEN
X JDC = ISAMAX(NBL,DC,1)
X DCMAX = AMAX1(DCMAX,ABS(DC(JDC)))
X ENDIF
X DO 19400 I = 1, NBL
X LWKSP1(I) = CTOT(I,KC) .LE. (-1.E-2)
X19400 CONTINUE
C
X SUM = 0.0
X DO 19600 I = 1, NBL
X SUM = SUM + CTOT(I,KC)*VB(I)
X19600 CONTINUE
X OP(KC) = SUM*EPHI1
X IF (KC .GT. 8) OP(KC) = OP(KC) + TRD(KC-8)*EPHI1
X19800 CONTINUE
X20000 CONTINUE
X SUM = 0.0
X DO 20200 I = 1, NBL
X SUM = SUM + (C6HATS(I)+C6ADSS(I))*VB(I)
X20200 CONTINUE
X OP(6) = OP(6) + SUM*EPHI1
X DO 20400 KC = 1, N
X RELERR(KC) = 0.0
X TEMP(KC) = CUMI(KC) + OIP(KC)
X IF (TEMP(KC) .GT. 1.E-7) RELERR(KC) = ABS(TEMP(KC)+CUMP(KC)-OP(
X 1 KC))/TEMP(KC)
X20400 CONTINUE
X RETURN
X END
X SUBROUTINE SUB018(A,U,F,Z)
X PARAMETER (NXY=100000,NX=100000)
X DIMENSION A(NXY,7),U(NXY),F(NXY),Z(NXY)
X Z(1) = 0.0
X KE = NXY - NX + 2
X NU = NX - 2
X
X DO 1200 KK = 2, KE, 65535
X KKE = (KK-1) + MIN0(65535,KE-(KK-1))
X DO 1000 K = KK, KKE
X Z(K) = A(K,3)*A(K-1,6)*U(K+NU)
X 1000 CONTINUE
X 1200 CONTINUE
X
X KB = KE + 1
X DO 1400 K = KB, NXY
X Z(K) = 0.0
X 1400 CONTINUE
X NA = (-NX) + 1
X NU = NA + 1
X
X DO 1600 K = 1, NX
X Z(K) = Z(K) + F(K)
X 1600 CONTINUE
X
X DO 2000 KK = NX + 1, NXY, 65535
X KKE = (KK-1) + MIN0(65535,NXY-(KK-1))
X DO 1800 K = KK, KKE
X Z(K) = (Z(K)+F(K)) + A(K,2)*A(K+NA,5)*U(K+NU)
X 1800 CONTINUE
X 2000 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB019
X PARAMETER (MR=100,MT=16,MX=16)
X PARAMETER (PI=3.141592653589793)
X COMMON /DATA/
X 1 VR(MR+1,MT+1,6*MX),VC(MR+1,MT+1,6*MX),WR(MR+1,MT+1,6*MX),
X 1 WC(MR+1,MT+1,6*MX)
X COMPLEX CVEC(MR+1),CFAC
X DO 1400 J = 1, MT + 1
X DO 1200 K = 1, 2*MX
X
X J1 = J - 1
X K1 = K - 1
X IF (K1 .GT. MX) K1 = K1 - 2*MX
X CFAC = EXP((0.,1.)*(J1*PI/(2*MT)+K1*PI/(2*MX)))
X DO 1000 I = 1, MR + 1
X
X CVEC(I) = VR(I,J,K) + (0.,1.)*VC(I,J,K)
X CVEC(I) = CFAC*CVEC(I)
X VR(I,J,K) = CVEC(I)
X VC(I,J,K) = (0.,-1.)*CVEC(I)
X
X CVEC(I) = VR(I,J,K+2*MX) + (0.,1.)*VC(I,J,K+2*MX)
X CVEC(I) = CFAC*CVEC(I)
X VR(I,J,K+2*MX) = CVEC(I)
X VC(I,J,K+2*MX) = (0.,-1.)*CVEC(I)
X
X CVEC(I) = VR(I,J,K+4*MX) + (0.,1.)*VC(I,J,K+4*MX)
X CVEC(I) = CFAC*CVEC(I)
X VR(I,J,K+4*MX) = CVEC(I)
X VC(I,J,K+4*MX) = (0.,-1.)*CVEC(I)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X
X DO 2000 J = 1, MT + 1
X DO 1800 K = 1, 2*MX
X J1 = J - 1
X K1 = K - 1
X IF (K1 .GT. MX) K1 = K1 - 2*MX
X
X CFAC = EXP((0.,-1.)*(J1*PI/(2*MT)+K1*PI/(2*MX)))
X DO 1600 I = 1, MR + 1
X CVEC(I) = WR(I,J,K) + (0.,1.)*WC(I,J,K)
X CVEC(I) = CFAC*CVEC(I)
X WR(I,J,K) = CVEC(I)
X WC(I,J,K) = (0.,-1.)*CVEC(I)
X
X CVEC(I) = WR(I,J,K+2*MX) + (0.,1.)*WC(I,J,K+2*MX)
X CVEC(I) = CFAC*CVEC(I)
X WR(I,J,K+2*MX) = CVEC(I)
X WC(I,J,K+2*MX) = (0.,-1.)*CVEC(I)
X
X CVEC(I) = WR(I,J,K+4*MX) + (0.,1.)*WC(I,J,K+4*MX)
X CVEC(I) = CFAC*CVEC(I)
X WR(I,J,K+4*MX) = CVEC(I)
X WC(I,J,K+4*MX) = (0.,-1.)*CVEC(I)
X
X 1600 CONTINUE
X 1800 CONTINUE
X 2000 CONTINUE
X RETURN
X END
X SUBROUTINE SUB020(S,KKP,KKR)
X PARAMETER(JKLMAX=40,IMX=29791)
X COMMON/DATA/Q(5,IMX), X(IMX), Y(IMX), Z(IMX)
X COMMON/DATA/R(JKLMAX), RTXYZ(4,JKLMAX), DJ(IMX)
X DIMENSION KKP(JKLMAX),KKR(JKLMAX),S(5,IMX)
X DATA JMAX/JKLMAX/,KMAX/JKLMAX/,LMAX/JKLMAX/
X DATA JM/JKLMAX/,KM/JKLMAX/,LM/JKLMAX/
X DATA JMM/JKLMAX/,KMM/JKLMAX/LMM/JKLMAX/
X DATA KEND2/2/,KENDM/JKLMAX/,KK/0/,LL/0/
X DATA SMU/1.0/,SMUIM/1.0/
X DO 2000 L = 2, LM
X DO 1800 K = KEND2, KENDM
X IKL = (K-1)*KK + (L-1)*LL
X DO 1200 N = 1, 4
X DO 1000 J = 3, JMM
X I = IKL + J
X SMJ = SMU*DJ(I)
X D4Q=Q(N,I+2)-4.*Q(N,I+1)+6.*Q(N,I)-4.*Q(N,I-1)+Q(N,I-2)
X S(N,I) = S(N,I) - SMJ*D4Q
X 1000 CONTINUE
X 1200 CONTINUE
C. J=2
X I = IKL + 2
X SMJ = SMU*DJ(I)
X DO 1400 N = 1, 4
X D4Q=Q(N,I-1)-4.*Q(N,I)+6.*Q(N,I+1)-4.*Q(N,I+2)+Q(N,I+3)
X S(N,I) = S(N,I) - SMJ*D4Q
X 1400 CONTINUE
X I = IKL + JM
X SMJ = SMU*DJ(I)
X DO 1600 N = 1, 4
X D2Q = Q(N,I+1) - 2.*Q(N,I) + Q(N,I-1)
X S(N,I) = S(N,I) + SMJ*D2Q
X 1600 CONTINUE
X 1800 CONTINUE
X 2000 CONTINUE
X 2200 CONTINUE
X DO 5600 L = 2, LM
X DO 5400 J = 2, JM
X IJL = J + (L-1)*LL
X DO 2600 N = 1, 4
X K = 2
X I = IJL + (K-1)*KK
X DO 2400 K = 3, KMM
X I = I + KK
X SMJ = SMU*DJ(I)
X D4Q = Q(N,I-KK-KK) - 4.*(Q(N,I-KK)+Q(N,I+KK)) + 6.*Q(N,I)
X 1 + Q(N,I+KK+KK)
X S(N,I) = S(N,I) - SMJ*D4Q
X 2400 CONTINUE
X 2600 CONTINUE
X I = IJL + KK
X SMJ = SMU*DJ(I)
X DO 2800 N = 1, 4
X D4Q = Q(N,I-KK) - 4.*Q(N,I) + 6.*Q(N,I+KK) - 4.*Q(N,I+KK+KK)
X 1 + Q(N,I+KK+KK+KK)
X S(N,I) = S(N,I) - SMJ*D4Q
X 2800 CONTINUE
X I = IJL + (KM-1)*KK
X SMJ = SMU*DJ(I)
X DO 3000 N = 1, 4
X D4Q = Q(N,I+KK) - 4.*Q(N,I) + 6.*Q(N,I-KK) - 4.*Q(N,I-KK-KK)
X 1 + Q(N,I-KK-KK-KK)
X S(N,I) = S(N,I) - SMJ*D4Q
X 3000 CONTINUE
X GO TO 5200
X 3200 CONTINUE
C. K=2
X I = IJL + KK
X SMJ = SMU*DJ(I)
X DO 3400 N = 1, 4
X D4Q = Q(N,I+KK+KK) - 4.*(Q(N,I+KK)+Q(N,I-KK)) + 7.*Q(N,I)
X IF (N .EQ. 3) D4Q = D4Q - 2.*Q(3,I)
X S(N,I) = S(N,I) - SMJ*D4Q
X 3400 CONTINUE
C. K=KM
X I = IJL + (KM-1)*KK
X SMJ = SMU*DJ(I)
X DO 3600 N = 1, 4
X D4Q = Q(N,I-KK-KK) - 4.*(Q(N,I-KK)+Q(N,I+KK)) + 7.*Q(N,I)
X IF (N .EQ. 3) D4Q = D4Q - 2.*Q(3,I)
X S(N,I) = S(N,I) - SMJ*D4Q
X 3600 CONTINUE
X GO TO 5200
X 3800 CONTINUE
X DO 5000 NK = 1, 2
X GO TO (4000,4200) NK
X 4000 CONTINUE
X KBGN = 1
X KEND = 2
X GO TO 4400
X 4200 CONTINUE
X KBGN = KM
X KEND = KMAX
X 4400 CONTINUE
X DO 4800 K = KBGN, KEND
X KR = KKR(K)
X KP = KKP(K)
X KRR = KKR(KR)
X KPP = KKP(KP)
X I = IJL + (K-1)*KK
X IR = IJL + (KR-1)*KK
X IP = IJL + (KP-1)*KK
X IRR = IJL + (KRR-1)*KK
X IPP = IJL + (KPP-1)*KK
X SMJ = SMU*DJ(I)
X DO 4600 N = 1, 4
X D4Q=Q(N,IRR)+6.*Q(N,I)+Q(N,IPP)-4.*(Q(N,IR)+Q(N,IP))
X S(N,I) = S(N,I) - SMJ*D4Q
X 4600 CONTINUE
X 4800 CONTINUE
X 5000 CONTINUE
X 5200 CONTINUE
X 5400 CONTINUE
X 5600 CONTINUE
X 5800 CONTINUE
X DO 7000 J = 2, JM
X DO 6800 K = KEND2, KENDM
X IJK = J + (K-1)*KK
X DO 6200 N = 1, 4
X L = 2
X I = IJK + (L-1)*LL
X DO 6000 L = 3, LMM
X I = I + LL
X SMJ = SMU*DJ(I)
X D4Q = Q(N,I-LL-LL) - 4.*(Q(N,I-LL)+Q(N,I+LL)) + 6.*Q(N,I)
X 1 + Q(N,I+LL+LL)
X S(N,I) = S(N,I) - SMJ*D4Q
X 6000 CONTINUE
X 6200 CONTINUE
X I = IJK + LL
X SMJ = SMU*DJ(I)
X DO 6400 N = 1, 4
X D4Q = Q(N,I-LL) - 4.*Q(N,I) + 6.*Q(N,I+LL) - 4.*Q(N,I+LL+LL)
X 1 + Q(N,I+LL+LL+LL)
X S(N,I) = S(N,I) - SMJ*D4Q
X 6400 CONTINUE
X I = IJK + (LM-1)*LL
X SMJ = SMU*DJ(I)
X DO 6600 N = 1, 4
X D2Q = (-Q(N,I+LL)) + 2.*Q(N,I) - Q(N,I-LL)
X S(N,I) = S(N,I) - SMJ*D2Q
X 6600 CONTINUE
X 6800 CONTINUE
X 7000 CONTINUE
X 7200 CONTINUE
X RETURN
X END
X SUBROUTINE SUB021(NOP,NATOMS,NION,NSS)
X COMMON /DATA/ FX(2000),FY(2000),FZ(2000)
X COMMON /DATA/ X0(2000),Y0(2000),Z0(2000)
X COMMON /DATA/ TX(2000),TY(2000),TZ(2000)
X COMMON /DATA/ SX(2000),SY(2000),SZ(2000)
X COMMON /DATA/ FSX(2000),FSY(2000),FSZ(2000)
X COMMON /DATA/A(3),B(3),C(3),AA(3,650),BB(3,650),CC(3,650)
X X ,AAA(650),BBB(650),CCC(650),AAAA,BBBB,CCCC
X COMMON/DATA/ TTRAN(3),TROT(3),RHO,VOLM,DT,FNOP,BREAK
X X ,DM(3,3),QM(9,3),TE(3),RE(3),TTS(3),RTS(3)
X X ,R2(3),EWW,EWI,EWA,EII,EIA
X COMMON/DATA/ DSUMM(3),DRI(3,3),DQ(30),DSITE(3,30)
X X ,UNITM,UNITL,UNITE,COULF,ENERF,TEMPF,TSTEP
C COMMON/DATA/ QQ(11,11),AD(5),BD(5)
X COMMON/DATA/ QQ(11,11),
X 1A1,A2,A3,A4,A5,B1,B2,B3,B4,B5
X COMMON /DATA/ AA1(4),AA2(4),BB1(4),BB2(4),SFX(4),SFY(4),SFZ(4)
X COMMON /DATA/ FOX(2000),FOY(2000),FOZ(2000),
X 1F1X(2000),F1Y(2000),
X 1F1Z(2000),F2X(2000),F2Y(2000),F2Z(2000),
X 2FPX(2000),FPY(2000),FPZ(2000),
X 3FAX(2000),FAY(2000),FAZ(2000),FIX(100),FIY(100),FIZ(100),
X 4FOXP(2000),FOYP(2000),FOZP(2000),F1XP(2000),F1YP(2000),
X 1F1ZP(2000),F2XP(2000),F2YP(2000),F2ZP(2000),
X 2FPXP(2000),FPYP(2000),FPZP(2000),
X 4XDT(2000),YDT(2000),ZDT(2000)
X
X DIMENSION NSITES(3),NSPECI(3),IND(2000)
X DATA NSITES/3*1/,NSPECI/3*100/,IND/2000*0/
X
X ALENGT = (22./UNITL)*.001
X ALENGM = 1./ALENGT
X B1M = -B1
X B2M = -B2
X B3M = -B3
X B4M = -B4
X EFFE = 0
X EWW = 0
X EWI = 0
X EWA = 0
X EII = 0
X EIA = 0
X NSP = NSPECI(1)
X NSST = NSS + NION + NATOMS
X DO 1000 I = 1, NSST
X FSX(I) = 0
X FSY(I) = 0
X FSZ(I) = 0
X 1000 CONTINUE
X ISIT = NSITES(1)
X RCUTS = 64.E-20/UNITL/UNITL
X DO 1200 I = 1, NSP
X FPX(I) = 0
X FPY(I) = 0
X FPZ(I) = 0
X FOX(I) = 0
X FOY(I) = 0
X FOZ(I) = 0
X F1X(I) = 0
X F1Y(I) = 0
X F1Z(I) = 0
X F2X(I) = 0
X F2Y(I) = 0
X F2Z(I) = 0
X 1200 CONTINUE
X DO 2800 I = 2, NSP
X INS = (I-1)*ISIT
X FXO = 0
X FYO = 0
X FZO = 0
X FX1 = 0
X FY1 = 0
X FZ1 = 0
X FX2 = 0
X FY2 = 0
X FZ2 = 0
X FXP = 0
X FYP = 0
X FZP = 0
X DO 1600 J = 1, I - 1
X IND(J) = 0
X JNS = (J-1)*ISIT
X XD = X0(I) - X0(J)
X YD = Y0(I) - Y0(J)
X ZD = Z0(I) - Z0(J)
X XDT(J) = XD - 2.*ALENGT*(XD*ALENGM)
X YDT(J) = YD - 2.*ALENGT*(YD*ALENGM)
X ZDT(J) = ZD - 2.*ZD
X DXS = XDT(J) + SX(INS+1)
X DYS = YDT(J) + SY(INS+1)
X DZS = ZDT(J) + SZ(INS+1)
X RX = DXS - SX(JNS+1)
X RY = DYS - SY(JNS+1)
X RZ = DZS - SZ(JNS+1)
X RSQ = RX*RX + RY*RY + RZ*RZ
X IF (RSQ .GE. RCUTS) GO TO 1400
X IND(J) = 1
X 1400 CONTINUE
X 1600 CONTINUE
X L = 0
X DO 2000 J = 1, I - 1
X IF (IND(J) .EQ. 0) GO TO 1800
X L = L + 1
X IND(L) = J
X 1800 CONTINUE
X 2000 CONTINUE
X IF (L .EQ. 0) GO TO 2600
X DO 2200 J = 1, L
X K = IND(J)
X JNS = (K-1)*ISIT
X XD = XDT(K)
X YD = YDT(K)
X ZD = ZDT(K)
X DXS = XD + SX(INS+1)
X DYS = YD + SY(INS+1)
X DZS = ZD + SZ(INS+1)
X RX = DXS - SX(JNS+1)
X RY = DYS - SY(JNS+1)
X RZ = DZS - SZ(JNS+1)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X EWWT = A1*EXP(B1M*R)
X FOR = (B1*EWWT)*R
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXOT = FFX
X FYOT = FFY
X FZOT = FFZ
X FOXJ = FFX
X FOYJ = FFY
X FOZJ = FFZ
X RX = DXS - SX(JNS+2)
X RY = DYS - SY(JNS+2)
X RZ = DZS - SZ(JNS+2)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X ETERM1 = A2*EXP(B2M*R)
X ETERM2 = A3*EXP(B3M*R)
X FOR = (B2*ETERM1+B3*ETERM2)*R
X EWWT = EWWT + ETERM1 + ETERM2
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXOT = FXOT + FFX
X FYOT = FYOT + FFY
X FZOT = FZOT + FFZ
X F1XJ = FFX
X F1YJ = FFY
X F1ZJ = FFZ
X RX = DXS - SX(JNS+3)
X RY = DYS - SY(JNS+3)
X RZ = DZS - SZ(JNS+3)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X ETERM1 = A2*EXP(B2M*R)
X ETERM2 = A3*EXP(B3M*R)
X FOR = (B2*ETERM1+B3*ETERM2)*R
X EWWT = EWWT + ETERM1 + ETERM2
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXOT = FXOT + FFX
X FYOT = FYOT + FFY
X FZOT = FZOT + FFZ
X F2XJ = FFX
X F2YJ = FFY
X F2ZJ = FFZ
X DXS = XD + SX(INS+2)
X DYS = YD + SY(INS+2)
X DZS = ZD + SZ(INS+2)
X RX = DXS - SX(JNS+2)
X RY = DYS - SY(JNS+2)
X RZ = DZS - SZ(JNS+2)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,3)*RM1
X EFFET = TEX
X FOR = TEX*RSQ
X ETERM1 = A4*EXP(B4M*R)
X FOR = (B4*ETERM1)*RM1 + FOR
X EWWT = EWWT + ETERM1 + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX1T = FFX
X FY1T = FFY
X FZ1T = FFZ
X F1XJ = F1XJ + FFX
X F1YJ = F1YJ + FFY
X F1ZJ = F1ZJ + FFZ
X RX = DXS - SX(JNS+3)
X RY = DYS - SY(JNS+3)
X RZ = DZS - SZ(JNS+3)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,3)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X ETERM1 = A4*EXP(B4M*R)
X FOR = (B4*ETERM1)*RM1 + FOR
X EWWT = EWWT + ETERM1 + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX1T = FX1T + FFX
X FY1T = FY1T + FFY
X FZ1T = FZ1T + FFZ
X F2XJ = F2XJ + FFX
X F2YJ = F2YJ + FFY
X F2ZJ = F2ZJ + FFZ
X RX = DXS - SX(JNS+1)
X RY = DYS - SY(JNS+1)
X RZ = DZS - SZ(JNS+1)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X ETERM1 = A2*EXP(B2M*R)
X ETERM2 = A3*EXP(B3M*R)
X FOR = (B2*ETERM1+B3*ETERM2)*R
X EWWT = EWWT + ETERM1 + ETERM2
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX1T = FX1T + FFX
X FY1T = FY1T + FFY
X FZ1T = FZ1T + FFZ
X FOXJ = FOXJ + FFX
X FOYJ = FOYJ + FFY
X FOZJ = FOZJ + FFZ
X RX = DXS - SX(JNS+4)
X RY = DYS - SY(JNS+4)
X RZ = DZS - SZ(JNS+4)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,4)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X EWWT = EWWT + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX1T = FX1T + FFX
X FY1T = FY1T + FFY
X FZ1T = FZ1T + FFZ
X FPXJ = FFX
X FPYJ = FFY
X FPZJ = FFZ
X DXS = XD + SX(INS+3)
X DYS = YD + SY(INS+3)
X DZS = ZD + SZ(INS+3)
X RX = DXS - SX(JNS+2)
X RY = DYS - SY(JNS+2)
X RZ = DZS - SZ(JNS+2)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,3)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X ETERM1 = A4*EXP(B4M*R)
X FOR = (B4*ETERM1)*RM1 + FOR
X EWWT = EWWT + ETERM1 + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX2T = FFX
X FY2T = FFY
X FZ2T = FFZ
X F1XJ = F1XJ + FFX
X F1YJ = F1YJ + FFY
X F1ZJ = F1ZJ + FFZ
X RX = DXS - SX(JNS+3)
X RY = DYS - SY(JNS+3)
X RZ = DZS - SZ(JNS+3)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,3)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X ETERM1 = A4*EXP(B4M*R)
X FOR = (B4*ETERM1)*RM1 + FOR
X EWWT = EWWT + ETERM1 + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX2T = FX2T + FFX
X FY2T = FY2T + FFY
X FZ2T = FZ2T + FFZ
X F2XJ = F2XJ + FFX
X F2YJ = F2YJ + FFY
X F2ZJ = F2ZJ + FFZ
X RX = DXS - SX(JNS+1)
X RY = DYS - SY(JNS+1)
X RZ = DZS - SZ(JNS+1)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X ETERM1 = A2*EXP(B2M*R)
X ETERM2 = A3*EXP(B3M*R)
X FOR = (B2*ETERM1+B3*ETERM2)*R
X EWWT = EWWT + ETERM1 + ETERM2
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX2T = FX2T + FFX
X FY2T = FY2T + FFY
X FZ2T = FZ2T + FFZ
X FOXJ = FOXJ + FFX
X FOYJ = FOYJ + FFY
X FOZJ = FOZJ + FFZ
X RX = DXS - SX(JNS+4)
X RY = DYS - SY(JNS+4)
X RZ = DZS - SZ(JNS+4)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,4)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X EWWT = EWWT + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FX2T = FX2T + FFX
X FY2T = FY2T + FFY
X FZ2T = FZ2T + FFZ
X FPXJ = FPXJ + FFX
X FPYJ = FPYJ + FFY
X FPZJ = FPZJ + FFZ
X DXS = XD + SX(INS+4)
X DYS = YD + SY(INS+4)
X DZS = ZD + SZ(INS+4)
X RX = DXS - SX(JNS+2)
X RY = DYS - SY(JNS+2)
X RZ = DZS - SZ(JNS+2)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,4)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X EWWT = EWWT + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXPT = FFX
X FYPT = FFY
X FZPT = FFZ
X F1XJ = F1XJ + FFX
X F1YJ = F1YJ + FFY
X F1ZJ = F1ZJ + FFZ
X RX = DXS - SX(JNS+3)
X RY = DYS - SY(JNS+3)
X RZ = DZS - SZ(JNS+3)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(2,4)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X EWWT = EWWT + TEX
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXPT = FXPT + FFX
X FYPT = FYPT + FFY
X FZPT = FZPT + FFZ
X F2XJ = F2XJ + FFX
X F2YJ = F2YJ + FFY
X F2ZJ = F2ZJ + FFZ
X RX = DXS - SX(JNS+4)
X RY = DYS - SY(JNS+4)
X RZ = DZS - SZ(JNS+4)
X RSQ = RX*RX + RY*RY + RZ*RZ
X R = SQRT(RSQ)
X RM1 = R
X TEX = QQ(4,4)*RM1
X EFFET = EFFET + TEX
X FOR = TEX*RSQ
X EWWT = EWWT + TEX
X EWW = EWWT + EWW
X EFFE = EFFET + EFFE
X FFX = RX*FOR
X FFY = RY*FOR
X FFZ = RZ*FOR
X FXPT = FXPT + FFX
X FYPT = FYPT + FFY
X FZPT = FZPT + FFZ
X FPXJ = FPXJ + FFX
X FPYJ = FPYJ + FFY
X FPZJ = FPZJ + FFZ
X FXO = FXOT + FXO
X FYO = FYOT + FYO
X FZO = FZOT + FZO
X FX1 = FX1T + FX1
X FY1 = FY1T + FY1
X FZ1 = FZ1T + FZ1
X FX2 = FX2T + FX2
X FY2 = FY2T + FY2
X FZ2 = FZ2T + FZ2
X FXP = FXPT + FXP
X FYP = FYPT + FYP
X FZP = FZPT + FZP
X FOXP(J) = FOXJ
X FOYP(J) = FOYJ
X FOZP(J) = FOZJ
X F1XP(J) = F1XJ
X F1YP(J) = F1YJ
X F1ZP(J) = F1ZJ
X F2XP(J) = F2XJ
X F2YP(J) = F2YJ
X F2ZP(J) = F2ZJ
X FPXP(J) = FPXJ
X FPYP(J) = FPYJ
X FPZP(J) = FPZJ
X 2200 CONTINUE
X DO 2400 J = 1, L
X K = IND(J)
X FOX(K) = FOX(K) - FOXP(J)
X FOY(K) = FOY(K) - FOYP(J)
X FOZ(K) = FOZ(K) - FOZP(J)
X F1X(K) = F1X(K) - F1XP(J)
X F1Y(K) = F1Y(K) - F1YP(J)
X F1Z(K) = F1Z(K) - F1ZP(J)
X F2X(K) = F2X(K) - F2XP(J)
X F2Y(K) = F2Y(K) - F2YP(J)
X F2Z(K) = F2Z(K) - F2ZP(J)
X FPX(K) = FPX(K) - FPXP(J)
X FPY(K) = FPY(K) - FPYP(J)
X FPZ(K) = FPZ(K) - FPZP(J)
X 2400 CONTINUE
X FOX(I) = FOX(I) + FXO
X FOY(I) = FOY(I) + FYO
X FOZ(I) = FOZ(I) + FZO
X F1X(I) = F1X(I) + FX1
X F1Y(I) = F1Y(I) + FY1
X F1Z(I) = F1Z(I) + FZ1
X F2X(I) = F2X(I) + FX2
X F2Y(I) = F2Y(I) + FY2
X F2Z(I) = F2Z(I) + FZ2
X FPX(I) = FPX(I) + FXP
X FPY(I) = FPY(I) + FYP
X FPZ(I) = FPZ(I) + FZP
X 2600 CONTINUE
X 2800 CONTINUE
X ISIT = NSITES(1)
X NSP = NSPECI(1)
X IF (NION .LE. 0) GO TO 3400
X ION = 0
X DO 3200 ION = 1, NION
X K = NSP + ION
X JSP = NSS + ION
X XX = 0
X YY = 0
X ZZ = 0
X DO 3000 I = 1, NSP
X INS = (I-1)*ISIT
X XD = X0(I) - X0(K)
X YD = Y0(I) - Y0(K)
X ZD = Z0(I) - Z0(K)
X XD = XD - 2.*ALENGT*(XD*ALENGM)
X YD = YD - 2.*ALENGT*(YD*ALENGM)
X ZD = ZD - 2.*ZD
X DX = XD + SX(INS+1)
X DY = YD + SY(INS+1)
X DZ = ZD + SZ(INS+1)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = A(1)*DSQI
X T2 = B(1)*D6I
X T3 = C(1)*D12I
X EWIT = T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X XO = DX*GGG
X YO = DY*GGG
X ZO = DZ*GGG
X DX = XD + SX(INS+2)
X DY = YD + SY(INS+2)
X DZ = ZD + SZ(INS+2)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = A(2)*DSQI
X T2 = B(2)*D6I
X T3 = C(2)*D12I
X EWIT = EWIT + T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X X1 = DX*GGG
X Y1 = DY*GGG
X Z1 = DZ*GGG
X DX = XD + SX(INS+3)
X DY = YD + SY(INS+3)
X DZ = ZD + SZ(INS+3)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = A(3)*DSQI
X T2 = B(3)*D6I
X T3 = C(3)*D12I
X EWIT = EWIT + T1 + T2 + T3
X EWI = EWI + EWIT
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X X2 = DX*GGG
X Y2 = DY*GGG
X Z2 = DZ*GGG
X FOX(I) = FOX(I) + XO
X FOY(I) = FOY(I) + YO
X FOZ(I) = FOZ(I) + ZO
X F1X(I) = F1X(I) + X1
X F1Y(I) = F1Y(I) + Y1
X F1Z(I) = F1Z(I) + Z1
X F2X(I) = F2X(I) + X2
X F2Y(I) = F2Y(I) + Y2
X F2Z(I) = F2Z(I) + Z2
X XX = XX + XO + X1 + X2
X YY = YY + YO + Y1 + Y2
X ZZ = ZZ + ZO + Z1 + Z2
X 3000 CONTINUE
X FSX(JSP) = FSX(JSP) - XX
X FSY(JSP) = FSY(JSP) - YY
X FSZ(JSP) = FSZ(JSP) - ZZ
X 3200 CONTINUE
X 3400 CONTINUE
X DO 3600 IA = 1, NATOMS
X FAX(IA) = 0
X FAY(IA) = 0
X FAZ(IA) = 0
X 3600 CONTINUE
X ISIT = NSITES(1)
X NSP = NSPECI(1)
X DO 4000 I = 1, NSP
X INS = (I-1)*ISIT
X DO 3800 IA = 1, NATOMS
X K = IA + NOP
X XD = X0(I) - X0(K)
X YD = Y0(I) - Y0(K)
X ZD = Z0(I) - Z0(K)
X XD = XD - 2.*ALENGT*(XD*ALENGM)
X YD = YD - 2.*ALENGT*(YD*ALENGM)
X ZD = ZD - 2.*ZD
X DX = XD + SX(INS+1)
X DY = YD + SY(INS+1)
X DZ = ZD + SZ(INS+1)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = AA(1,IA)*DSQI
X T2 = BB(1,IA)*D6I
X T3 = CC(1,IA)*D12I
X EWAT = T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X FOX(I) = FOX(I) + DX*GGG
X FOY(I) = FOY(I) + DY*GGG
X FOZ(I) = FOZ(I) + DZ*GGG
X FAX(IA) = FAX(IA) + DX*GGG
X FAY(IA) = FAY(IA) + DY*GGG
X FAZ(IA) = FAZ(IA) + DZ*GGG
X DX = XD + SX(INS+2)
X DY = YD + SY(INS+2)
X DZ = ZD + SZ(INS+2)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = AA(2,IA)*DSQI
X T2 = BB(2,IA)*D6I
X T3 = CC(2,IA)*D12I
X EWAT = EWAT + T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X F1X(I) = F1X(I) + DX*GGG
X F1Y(I) = F1Y(I) + DY*GGG
X F1Z(I) = F1Z(I) + DZ*GGG
X FAX(IA) = FAX(IA) + DX*GGG
X FAY(IA) = FAY(IA) + DY*GGG
X FAZ(IA) = FAZ(IA) + DZ*GGG
X DX = XD + SX(INS+3)
X DY = YD + SY(INS+3)
X DZ = ZD + SZ(INS+3)
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = AA(3,IA)*DSQI
X T2 = BB(3,IA)*D6I
X T3 = CC(3,IA)*D12I
X EWAT = EWAT + T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X F2X(I) = F2X(I) + DX*GGG
X F2Y(I) = F2Y(I) + DY*GGG
X F2Z(I) = F2Z(I) + DZ*GGG
X FAX(IA) = FAX(IA) + DX*GGG
X FAY(IA) = FAY(IA) + DY*GGG
X FAZ(IA) = FAZ(IA) + DZ*GGG
X EWA = EWA + EWAT
X 3800 CONTINUE
X 4000 CONTINUE
X DO 4200 I = 1, NSP
X INS = (I-1)*ISIT
X FSX(INS+1) = FSX(INS+1) + FOX(I)
X FSY(INS+1) = FSY(INS+1) + FOY(I)
X FSZ(INS+1) = FSZ(INS+1) + FOZ(I)
X FSX(INS+2) = FSX(INS+2) + F1X(I)
X FSY(INS+2) = FSY(INS+2) + F1Y(I)
X FSZ(INS+2) = FSZ(INS+2) + F1Z(I)
X FSX(INS+3) = FSX(INS+3) + F2X(I)
X FSY(INS+3) = FSY(INS+3) + F2Y(I)
X FSZ(INS+3) = FSZ(INS+3) + F2Z(I)
X FSX(INS+4) = FSX(INS+4) + FPX(I)
X FSY(INS+4) = FSY(INS+4) + FPY(I)
X FSZ(INS+4) = FSZ(INS+4) + FPZ(I)
X 4200 CONTINUE
X IF (NION .LE. 0) GO TO 5800
X DO 4600 I = 1, NION
X K = I + NSP
X ISP = NSS + I
X XX = 0
X YY = 0
X ZZ = 0
X XD = X0(K)
X YD = Y0(K)
X ZD = Z0(K)
X DO 4400 J = 1, NATOMS
X L = NOP + J
X DX = XD - X0(L)
X DY = YD - Y0(L)
X DZ = ZD - Z0(L)
X DX = DX - 2.*ALENGT*(DX*ALENGM)
X DY = DY - 2.*ALENGT*(DY*ALENGM)
X DZ = DZ - 2.*DZ
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = AAA(J)*DSQI
X T2 = BBB(J)*D6I
X T3 = CCC(J)*D12I
X EIA = EIA + T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X XX = XX + GGG*DX
X YY = YY + GGG*DY
X ZZ = ZZ + GGG*DZ
X FAX(J) = FAX(J) + GGG*DX
X FAY(J) = FAY(J) + GGG*DY
X FAZ(J) = FAZ(J) + GGG*DZ
X 4400 CONTINUE
X FSX(ISP) = FSX(ISP) + XX
X FSY(ISP) = FSY(ISP) + YY
X FSZ(ISP) = FSZ(ISP) + ZZ
X 4600 CONTINUE
X DO 4800 IA = 1, NATOMS
X JSP = NSS + NION + IA
X FSX(JSP) = FSX(JSP) - FAX(IA)
X FSY(JSP) = FSY(JSP) - FAY(IA)
X FSZ(JSP) = FSZ(JSP) - FAZ(IA)
X 4800 CONTINUE
X IF (NION .EQ. 1) GO TO 5800
X DO 5000 I = 1, NION
X FIX(I) = 0
X FIY(I) = 0
X FIZ(I) = 0
X 5000 CONTINUE
X DO 5400 I = 2, NION
X XX = 0
X YY = 0
X ZZ = 0
X K = I + NSP
X XD = X0(K)
X YD = Y0(K)
X ZD = Z0(K)
X DO 5200 J = 1, I - 1
X L = NSP + J
X JSP = NSS + J
X DX = XD - X0(L)
X DY = YD - Y0(L)
X DZ = ZD - Z0(L)
X DX = DX - 2.*ALENGT*(DX*ALENGM)
X DY = DY - 2.*ALENGT*(DY*ALENGM)
X DZ = DZ - 2.*DZ
X DD = DX*DX + DY*DY + DZ*DZ
X DDI = DD
X DSQI = SQRT(DDI)
X D6I = DDI*DDI*DDI
X D12I = D6I*D6I
X T1 = AAAA*DSQI
X T2 = BBBB*D6I
X T3 = CCCC*D12I
X EII = EII + T1 + T2 + T3
X GGG = T1 + 6.0*T2 + 12.0*T3
X GGG = GGG*DDI
X XX = XX + GGG*DX
X YY = YY + GGG*DY
X ZZ = ZZ + GGG*DZ
X FSX(JSP) = FSX(JSP) - GGG*DX
X FSY(JSP) = FSY(JSP) - GGG*DY
X FSZ(JSP) = FSZ(JSP) - GGG*DZ
X 5200 CONTINUE
X FIX(I) = FIX(I) + XX
X FIY(I) = FIY(I) + YY
X FIZ(I) = FIZ(I) + ZZ
X 5400 CONTINUE
X DO 5600 I = 1, NION
X ISP = NSS + I
X FSX(ISP) = FSX(ISP) + FIX(I)
X FSY(ISP) = FSY(ISP) + FIY(I)
X FSZ(ISP) = FSZ(ISP) + FIZ(I)
X 5600 CONTINUE
X 5800 CONTINUE
X DO 6000 I = 1, NOP
X FX(I) = 0
X FY(I) = 0
X FZ(I) = 0
X 6000 CONTINUE
X DO 6200 I = 1, NSPECI(1)
X ISP = (I-1)*NSITES(1)
X FX(I)=FX(I)+FSX(ISP+1)+FSX(ISP+2)+FSX(ISP+3)+FSX(ISP+4)
X FY(I)=FY(I)+FSY(ISP+1)+FSY(ISP+2)+FSY(ISP+3)+FSY(ISP+4)
X FZ(I)=FZ(I)+FSZ(ISP+1)+FSZ(ISP+2)+FSZ(ISP+3)+FSZ(ISP+4)
X TX(I) = 0
X TY(I) = 0
X TZ(I) = 0
X TX(I) = FSZ(ISP+1)*SY(ISP+1) - FSY(ISP+1)*SZ(ISP+1) + FSZ(ISP+2)
X 1 *SY(ISP+2) - FSY(ISP+2)*SZ(ISP+2) + FSZ(ISP+3)*SY(ISP+3) -
X 2 FSY(ISP+3)*SZ(ISP+3) + FSZ(ISP+4)*SY(ISP+4) - FSY(ISP+4)*SZ(
X 3 ISP+4)
X TY(I) = FSX(ISP+1)*SZ(ISP+1) - FSZ(ISP+1)*SX(ISP+1) + FSX(ISP+2)
X 1 *SZ(ISP+2) - FSZ(ISP+2)*SX(ISP+2) + FSX(ISP+3)*SZ(ISP+3) -
X 2 FSZ(ISP+3)*SX(ISP+3) + FSX(ISP+4)*SZ(ISP+4) - FSZ(ISP+4)*SX(
X 3 ISP+4)
X TZ(I) = FSY(ISP+1)*SX(ISP+1) - FSX(ISP+1)*SY(ISP+1) + FSY(ISP+2)
X 1 *SX(ISP+2) - FSX(ISP+2)*SY(ISP+2) + FSY(ISP+3)*SX(ISP+3) -
X 2 FSX(ISP+3)*SY(ISP+3) + FSY(ISP+4)*SX(ISP+4) - FSX(ISP+4)*SY(
X 3 ISP+4)
X 6200 CONTINUE
X N = NSS
X DO 6400 I = NSPECI(1) + 1, 2000
X N = N + 1
X FX(I) = FSX(N)
X FY(I) = FSY(N)
X FZ(I) = FSZ(N)
X 6400 CONTINUE
X RETURN
X END
X SUBROUTINE SUB022(BUF,IW,NBES,K)
X PARAMETER (NX=125, NY=125, NZ=10)
X
X COMMON /DATA/ BES(150),DZR
X COMMON /DATA/ PP1(NX,NY,NZ),PM1(NX,NY,NZ)
X COMMON /DATA/ CDPP1(NX,NY,NZ),CDPM1(NX,NY,NZ)
X
X DIMENSION BUF(NX,NY,2,1)
X
X DO 1200 J = 1, NY
X DO 1000 I = 1, NX
X PP1(I,J,K) = BUF(I,J,2,IW)
X CDPP1(I,J,K) = BUF(I,J,1,IW)
X PM1(I,J,K) = BUF(I,J,1,IW)
X CDPM1(I,J,K) = BUF(I,J,2,IW)
X 1000 CONTINUE
X 1200 CONTINUE
X DO 1600 J = 1, NY
X DO 1400 I = 1, NX
X BUF(I,J,1,IW) = BES(1)*PM1(I,J,K) + BES(2)*PP1(I,J,K)
X BUF(I,J,2,IW) = BES(1)*CDPM1(I,J,K) + BES(2)*CDPP1(I,J,K)
X 1400 CONTINUE
X 1600 CONTINUE
X DZR = DZR*2.
X DO 2200 NB = 3, NBES
X DO 2000 J = 1, NY
X DO 1800 I = 1, NX
X BUF(I,J,1,IW) = BUF(I,J,1,IW) + BES(NB)*PM1(I,J,K)
X BUF(I,J,2,IW) = BUF(I,J,2,IW) + BES(NB)*CDPM1(I,J,K)
X CC = PM1(I,J,K)
X CCC = CDPM1(I,J,K)
X PM1(I,J,K) = PP1(I,J,K)
X CDPM1(I,J,K) = CDPP1(I,J,K)
X PP1(I,J,K) = CC
X CDPP1(I,J,K) = CCC
X 1800 CONTINUE
X 2000 CONTINUE
X 2200 CONTINUE
X RETURN
X END
X SUBROUTINE SUB023(VLCP)
X LOGICAL ORTHO
X PARAMETER (EPS=1.0E-6,EXCUT=30.0)
X PARAMETER (IUMX = 1)
X COMPLEX STRF
X PARAMETER ( MXH=4414, MXV=401, MPX=21, NPK= 60, NAX=17, NTYPX= 3,
X & LCORX=2, NPSX=3, NRX1=33, NRX2=32, NRX3=32, MAXTER=20,
X & NRXX=NRX1*NRX2*NRX3,MXHC= MXH/1.415,MXVC= MXV/1.415)
X PARAMETER ( NGM=3000,NTYP=NTYPX,NAT=NAX,NLC=2,NNL=3)
X PARAMETER ( DQ=0.034, NQX=127 )
X PARAMETER ( NQXE=NQX*(NQX+1)/2)
X COMMON/DATA/ TAU(3,NAX),
X + PI, TPI, FPI, ALAT, TPIBA, TPIBA2, OMEGA,
X + G(3,NRXX), GG(NRXX),
X + ECUT(MAXTER),
X + ZP(NPSX), CC(2,NPSX), ALPC(2,NPSX),
X + APS(6,0:3,NPSX), ALPS(3,0:3,NPSX),
X + XP(NPSX,NTYPX),
X + ZV(NTYPX),
X + TAB(NQX*(NQX+1)/2,0:LCORX,NTYPX),
X + STRF(NRXX,NTYPX), VLOC(NRXX,NTYPX)
X
X DIMENSION LMAX(NPSX), LCORE(NPSX),ITYP(NAX),
X + IPSEUD(NPSX,NTYPX), NPS(NTYPX)
X DO 1200 I = 1, NPSX
X LMAX(I) = 1
X LCORE(I) = 2
X DO 1000 J = 1, NTYPX
X IPSEUD(I,J) = 1
X NPS(J) = 3
X 1000 CONTINUE
X 1200 CONTINUE
X DO 1400 I = 1, NAX
X ITYP(I) = 2
X 1400 CONTINUE
X DO 2000 IG = 1, NGM
X DO 1800 NT = 1, NTYP
X STRF(IG,NT) = (0.0,0.0)
X DO 1600 N = 1, NAT
X IF (ITYP(N) .EQ. NT) THEN
X ARG = (G(1,IG)*TAU(1,N)+G(2,IG)*TAU(2,N)+G(3,IG)*TAU(3,N
X 1 ))*TPI
X STRF(IG,NT) = STRF(IG,NT) + CMPLX(COS(ARG),(-SIN(ARG)))
X ENDIF
X
X 1600 CONTINUE
X STRF(IG,NT) = STRF(IG,NT)/OMEGA
X 1800 CONTINUE
X 2000 CONTINUE
X DO 3600 IG = 1, NGM
X G2 = GG(IG)*TPIBA2
X DO 3400 NT = 1, NTYP
X VLOC(IG,NT) = 0.0
X DO 3200 NP = 1, NPS(NT)
X IP = IPSEUD(NP,NT)
X VLCP = 0.0
X LMX = LMAX(IP)
X LCR = LCORE(IP)
X ORTHO = LMX .EQ. LCR+1
X IF (G2 .LE. EPS) THEN
X DO 2200 I = 1, NLC
X VLCP = VLCP - CC(I,IP)*PI/ALPC(I,IP)
X 2200 CONTINUE
X ELSE
X DO 2600 I = 1, NLC
X G2A = 0.25*G2/ALPC(I,IP)
X IF (G2A .GT. EXCUT) GO TO 2400
X VLCP = VLCP + CC(I,IP)*FPI*EXP((-G2A))/G2
X 2400 CONTINUE
X 2600 CONTINUE
X ENDIF
X
X VLCP = -ZP(IP)*VLCP
X IF (ORTHO) THEN
X DO 3000 I = 1, NNL
X G2A = 0.25*G2/ALPS(I,LMX,IP)
X IF (G2A .GT. EXCUT) GO TO 2800
X VLCP = VLCP + (PI/ALPS(I,LMX,IP))**1.5*EXP((-G2A))*(
X 1 APS(I,LMX,IP)+APS(I+3,LMX,IP)*(1.5-G2A)/ALPS(I,LMX,
X 2 IP))
X 2800 CONTINUE
X 3000 CONTINUE
X ENDIF
X VLOC(IG,NT) = VLOC(IG,NT) + XP(IP,NT)*VLCP
X 3200 CONTINUE
X 3400 CONTINUE
X 3600 CONTINUE
X DO 4400 NT = 1, NTYP
X DO 4200 NP = 1, NPS(NT)
X IP = IPSEUD(NP,NT)
X LMX = LMAX(IP)
X LCR = LCORE(IP)
X DO 4000 IJ = 1, NQXE
X DO 3800 LAM = 0, LCR
X TAB(IJ,LAM,NT) = TAB(IJ,LAM,NT) + PI*XP(IP,NT)
X 3800 CONTINUE
X 4000 CONTINUE
X 4200 CONTINUE
X 4400 CONTINUE
X RETURN
X END
X SUBROUTINE SUB024(ZI,ZR,AI)
X PARAMETER (NM=100,N=100,M=100)
X COMMON /DATA/ AR(NM,N),TAU(2,N)
X DIMENSION ZR(NM,M),ZI(NM,M),AI(NM,N)
X
X IF (M .EQ. 0) GO TO 2400
X
X DO 1200 K = 1, N
X DO 1000 J = 1, M
X ZI(K,J) = -ZR(K,J)*TAU(2,K)
X ZR(K,J) = ZR(K,J)*TAU(1,K)
X 1000 CONTINUE
X 1200 CONTINUE
C
X IF (N .EQ. 1) GO TO 2400
X DO 2200 I = 2, N
X L = I - 1
X H = AI(I,I)
X IF (H .EQ. 0.0E0) GO TO 2000
C
X DO 1800 J = 1, M
X S = 0.0E0
X SI = 0.0E0
C
X DO 1400 K = 1, L
X S = S + AR(I,K)*ZR(K,J) - AI(I,K)*ZI(K,J)
X SI = SI + AR(I,K)*ZI(K,J) + AI(I,K)*ZR(K,J)
X 1400 CONTINUE
X S = S*H
X SI = SI*H
X DO 1600 K = 1, L
X ZR(K,J) = ZR(K,J) + S*AR(I,K) - SI*AI(I,K)
X ZI(K,J) = ZI(K,J) - SI*AR(I,K) + S*AI(I,K)
X 1600 CONTINUE
C
X 1800 CONTINUE
C
X 2000 CONTINUE
X 2200 CONTINUE
C
X 2400 CONTINUE
X RETURN
X END
X SUBROUTINE SUB025(GTEN)
X PARAMETER (NX=5,NY=100,NA=100)
X COMMON/DATA/
X 1 GXX(NX,NY), GXY(NX,NY), GYY(NX,NY), G(NX,NY),
X 1 JABC(NA,3), RTP(NA,3), C(3,NA), RP(3,NA), RM(3,NA), AM(NA),
X 1 RCM(3), EV(5), DR(3,5,NA),U(5,5),RGT(15)
X DIMENSION GTEN(5,5)
X PI = 3.1415926535898
X DX = NX
X DX = 2.*PI/DX
X DY = NY
X DY = 2.*PI/DY
X
X DO 4400 JX = 1, NX
X X = JX - (NX+1)/2
X X = X*DX
X
X DO 4200 JY = 1, NY
X Y = JY - (NY+1)/2
X Y = Y*DY
X
X DO 1000 K = 1, NA
X DR(1,1,K) = 0.
X DR(1,2,K) = RP(3,K)
X DR(1,3,K) = -RP(2,K)
X DR(2,1,K) = -RP(3,K)
X DR(2,2,K) = 0.
X DR(2,3,K) = RP(1,K)
X DR(3,1,K) = RP(2,K)
X DR(3,2,K) = -RP(1,K)
X DR(3,3,K) = 0.
X 1000 CONTINUE
X X = X + DX/6.
X X = X - 2.*DX/6.
X
X DO 1400 I = 1, 3
X DO 1200 K = 1, NA
X DR(I,4,K) = (RP(I,K)-RM(I,K))*4./DX
X 1200 CONTINUE
X 1400 CONTINUE
X X = X - DX/6.
X X = X + 4.*DX/6.
X X = X - 2.*DX/6.
X
X DO 1800 I = 1, 3
X DO 1600 K = 1, NA
X DR(I,4,K) = DR(I,4,K) + (RP(I,K)-RM(I,K))/2./DX
X 1600 CONTINUE
X 1800 CONTINUE
X Y = Y + DY/6.
X Y = Y - 2.*DY/6.
X
X DO 2200 I = 1, 3
X DO 2000 K = 1, NA
X DR(I,5,K) = (RP(I,K)-RM(I,K))*4./DY
X 2000 CONTINUE
X 2200 CONTINUE
X Y = Y - DY/6.
X Y = Y + 4.*DY/6.
X Y = Y - 2.*DY/6.
X
X DO 2600 I = 1, 3
X DO 2400 K = 1, NA
X DR(I,5,K) = DR(I,5,K) + (RP(I,K)-RM(I,K))/2./DY
X 2400 CONTINUE
X 2600 CONTINUE
X
X DO 3200 I = 1, 5
X DO 3000 J = I, 5
X S = 0.
X
X DO 2800 K = 1, NA
X S = S + AM(K)*(DR(1,I,K)*DR(1,J,K)+DR(2,I,K)*DR(2,J,K)+
X 1 DR(3,I,K)*DR(3,J,K))
X 2800 CONTINUE
X GTEN(I,J) = S
X GTEN(J,I) = S
X 3000 CONTINUE
X 3200 CONTINUE
X DET = 1.
X
X DO 3400 I = 1, 5
X IF (GTEN(I,I) .NE. 0) EV(I) = 505379.05/GTEN(I,I)
X DET = DET*GTEN(I,I)
X 3400 CONTINUE
X L = 0
X DO 4000 I = 1, 5
X DO 3800 J = I, 5
X S = 0.
X
X DO 3600 M = 1, 5
X S = S + U(I,M)*EV(M)*U(J,M)
X 3600 CONTINUE
X L = L + 1
X RGT(L) = S
X GTEN(I,J) = S
X 3800 CONTINUE
X 4000 CONTINUE
X GXX(JX,JY) = GTEN(4,4)
X GXY(JX,JY) = GTEN(4,5)
X GYY(JX,JY) = GTEN(5,5)
X G(JX,JY) = DET
X 4200 CONTINUE
X 4400 CONTINUE
X JX = (NX+1)/2
X JY = (NY+1)/2
X SC = .001
X IF (G(JX,JY) .NE. 0) SC = 10000./G(JX,JY)
X RETURN
X END
X SUBROUTINE SUB026(F)
X COMPLEX P,B,GAM2,DEL2,DEL4,G2O2B,FST,CDLNS,CDLNS0,EP,EPP
X COMPLEX DINC,DINT,YA,OVER,TERM,CX2,FCTP,FCTM
X COMPLEX ARGU,ARGUM
X COMMON /DATA/ P,B,GAM2,DEL2,DEL4,G2O2B,FST,CDLNS,CDLNS0
X COMMON /DATA/ DINC,DINT,YA(12),OVER,TERM,CX2,FCTP,FCTM
X COMMON /DATA/ ARGU,ARGUM,EP,EPP
X REAL MMBSJ0
X COMMON /DATA/ BES(43,43,24),MMBSJ0(43,43)
X COMMON /DATA/ XP(6),C(12),D(12),YR(12),YI(12)
X COMMON /DATA/ TL(24),TH(19),DTL(24),DTH(19),ZERO(40)
X DIMENSION IN(2),F(43)
X DATA IN/19,19/,IER/20/
X
X PI = 3.141592653
X HBARCP = .624008
X SSQ = 0.
C
X S = 52.8
X DO 3200 J = 1, 2
X IF (J .EQ. 2) S = 546.
X S = S*S
C
X DLNS = ALOG(S)
X CDLNS = CMPLX(DLNS,(-PI/2.))
X EP = CMPLX(XP(2),0.)
X REF = ALOG(100.)
X CDLNS0 = CDLNS - CMPLX(REF,0.)
X P = (XP(1)+EP*CDLNS0**2)/(1.+EP*CDLNS0**2)
X B = CMPLX(XP(3),0.) + CMPLX(XP(4),0.)*CDLNS0**2
X GAM2 = (.78,0.)
X DEL2 = CMPLX(XP(5),0.) + CMPLX(XP(6),0.)*CDLNS0**2
X DEL4 = DEL2**2/4.
X G2O2B = (.5,0.)*GAM2/B
X 1000 CONTINUE
C
X ISKIP = 1
X MAX = IN(J)
X
X DO 3000 I = 1, MAX, ISKIP
X TM = TL(I)
X IF (J .EQ. 2) TM = TH(I)
X DINT = (0.,0.)
X XL = 1.E-7
X T = -TM
X T1 = TM
X IF (I .EQ. 1) T1 = .1
X ADDI = T1 + 1.
X KMAX = 3.*ADDI
X IF (T1 .LT. 3.) KMAX = 4.*ADDI
X KMAX = MIN0(40,KMAX)
X IRUN = I + 24*(J-1)
X
X DO 1400 K = 1, KMAX
X XU = ZERO(K)/SQRT(T1)
X A = .5*(XU+XL)
X BB = XU - XL
X
X DO 1200 II = 1, 12
X ADD = BB*C(II)
X X = A + ADD
X IY = X*SQRT(TM)
X IY = MIN0(40,IY)
X BES(IRUN,K,II) = MMBSJ0(IY,IER)
X III = II + 12
X X = A - ADD
X IY = X*SQRT(TM)
X IY = MIN0(40,IY)
X BES(IRUN,K,III) = MMBSJ0(IY,IER)
X 1200 CONTINUE
X
X XL = XU
X 1400 CONTINUE
X 1600 CONTINUE
X XL = 1.E-7
X
X DO 2200 K = 1, KMAX
X XU = ZERO(K)/SQRT(T1)
X A = .5*(XL+XU)
X BB = XU - XL
X
X DO 1800 II = 1, 12
X ADD = BB*C(II)
X X = A + ADD
X CX2 = CMPLX(X*X,0.)
X ARGU = (1.,0.) - G2O2B*CX2
X ARGI = AIMAG(ARGU)
X TERM = G2O2B*CX2*(COS(ARGI)+(0.,1.)*SIN(ARGI))*EXP(REAL(
X 1 ARGU))
X ARGUM = -CX2/(4.*B)
X ARGI = AIMAG(ARGUM)
X OVER = P*(COS(ARGI)+(0.,1.)*SIN(ARGI))*EXP(REAL(ARGUM))*(
X 1 1.+DEL2*TERM+DEL4*TERM**2)
X Y = X*SQRT(TM)
X FCTP = (0.,1.)*CMPLX(X,0.)*((1.,0.)-CSQRT((1.,0.)-OVER))*
X 1 CMPLX(BES(IRUN,K,II),0.)
X X = A - ADD
X CX2 = CMPLX(X*X,0.)
X ARGU = (1.,0.) - G2O2B*CX2
X ARGI = AIMAG(ARGU)
X TERM = G2O2B*CX2*(COS(ARGI)+(0.,1.)*SIN(ARGI))*EXP(REAL(
X 1 ARGU))
X ARGUM = -CX2/(4.*B)
X ARGI = AIMAG(ARGUM)
X OVER = P*(COS(ARGI)+(0.,1.)*SIN(ARGI))*EXP(REAL(ARGUM))*(
X 1 1.+DEL2*TERM+DEL4*TERM**2)
X Y = X*SQRT(TM)
X III = II + 12
X FCTM = (0.,1.)*CMPLX(X,0.)*((1.,0.)-CSQRT((1.,0.)-OVER))*
X 1 CMPLX(BES(IRUN,K,III),0.)
X YA(II) = D(II)*(FCTP+FCTM)
X YR(II) = REAL(YA(II))
X YI(II) = AIMAG(YA(II))
X 1800 CONTINUE
X
X SSUM0 = 0
X SSUM1 = 0
X DO 2000 IJK = 1, 12
X SSUM0 = SSUM0 + YR(IJK)
X SSUM1 = SSUM1 + YI(IJK)
X 2000 CONTINUE
X DINCR = BB*SSUM0
X DINCI = BB*SSUM1
X DINC = CMPLX(DINCR,DINCI)
X DINT = DINT + DINC
X XL = XU
X 2200 CONTINUE
X
X 2400 CONTINUE
X FST = DINT
X IF (I .EQ. 1) STOT = 4.*PI*HBARCP**2*AIMAG(FST)
X DSIGMA = PI*HBARCP**2*CABS(FST)**2
X IF (J .EQ. 2) GO TO 2600
X DDT = DTL(I)
X RESIDD = ALOG(DSIGMA) - ALOG(DDT)
X IF (I.GT.16 .AND. I.LT.23) RESIDD = RESIDD*2.
X GO TO 2800
X 2600 CONTINUE
X DDT = DTH(I)
X RESIDD = ALOG(DSIGMA) - ALOG(DDT)
X 2800 CONTINUE
X IF (I.EQ.1 .OR. I.EQ.2) RESIDD = RESIDD*5.
X RESIDD = RESIDD/T1**.25
X F(IRUN) = RESIDD
X SSQ = SSQ + RESIDD**2
X 3000 CONTINUE
X 3200 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB027
X PARAMETER (NX=100,NY=100,NV=100)
X COMMON /DATA/ PS(NX,NY,NV),W(5,5),S(9)
X DIMENSION IX(9),IY(9)
X DO 1000 I = 1, 9
X IX(I) = I
X IY(I) = I
X 1000 CONTINUE
X W(1,1) = 1.
X W(2,1) = 4.
X W(3,1) = 6.
X W(4,1) = 4.
X W(5,1) = 1.
X DO 1200 K = 1, 5
X W(1,K) = W(K,1)
X 1200 CONTINUE
X DO 1600 K = 2, 5
X DO 1400 L = 2, 5
X W(K,L) = W(K,1)*W(1,L)
X 1400 CONTINUE
X 1600 CONTINUE
X LP = 0
X DO 3000 LV = 1, NV
X DO 2000 JX = 1, NX
X DO 1800 JY = 1, NY
X PS(JX,JY,LV) = 0.
X 1800 CONTINUE
X 2000 CONTINUE
X DO 2200 L = 1, 4
X IF (S(L) .NE. 0.) LP = L
X 2200 CONTINUE
X DO 2800 L = 1, LP
X JX = IX(L) + (NX+1)/2 - 3
X JY = IY(L) + (NY+1)/2 - 3
X DO 2600 KX = 1, 5
X JPX = JX + KX
X DO 2400 KY = 1, 5
X JPY = JY + KY
X PS(JPX,JPY,LV) = PS(JPX,JPY,LV) + W(KX,KY)*S(L)
X 2400 CONTINUE
X 2600 CONTINUE
X 2800 CONTINUE
X 3000 CONTINUE
X RETURN
X END
X SUBROUTINE SUB028
C
X PARAMETER (NM=1000,N=100)
X COMMON /DATA/ AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N)
C
X TAU(1,N) = 1.0E0
X TAU(2,N) = 0.0E0
C
X DO 1000 I = 1, N
X D(I) = AR(I,I)
X 1000 CONTINUE
X
X DO 4200 II = 1, N
X I = N + 1 - II
X L = I - 1
X H = 0.0E0
X SCALE = 0.0E0
X IF (L .LT. 1) GO TO 1400
X
X DO 1200 K = 1, L
X SCALE = SCALE + ABS(AR(I,K)) + ABS(AI(I,K))
X 1200 CONTINUE
C
X IF (SCALE .NE. 0.0E0) GO TO 1600
X TAU(1,L) = 1.0E0
X TAU(2,L) = 0.0E0
X 1400 CONTINUE
X E(I) = 0.0E0
X E2(I) = 0.0E0
X GO TO 4000
C
X 1600 CONTINUE
X DO 1800 K = 1, L
X AR(I,K) = AR(I,K)/SCALE
X AI(I,K) = AI(I,K)/SCALE
X H = H + AR(I,K)*AR(I,K) + AI(I,K)*AI(I,K)
X 1800 CONTINUE
C
X E2(I) = SCALE*SCALE*H
X G = SQRT(H)
X E(I) = SCALE*G
X F = 3.14
X IF (F .EQ. 0.0E0) GO TO 2000
X TAU(1,L) = (AI(I,L)*TAU(2,I)-AR(I,L)*TAU(1,I))/F
X SI = (AR(I,L)*TAU(2,I)+AI(I,L)*TAU(1,I))/F
X H = H + F*G
X G = 1.0E0 + G/F
X AR(I,L) = G*AR(I,L)
X AI(I,L) = G*AI(I,L)
X IF (L .EQ. 1) GO TO 3600
X GO TO 2200
X 2000 CONTINUE
X TAU(1,L) = -TAU(1,I)
X SI = TAU(2,I)
X AR(I,L) = G
X 2200 CONTINUE
X F = 0.0E0
C
X DO 3000 J = 1, L
X G = 0.0E0
X GI = 0.0E0
X
X DO 2400 K = 1, J
X G = G + AR(J,K)*AR(I,K) + AI(J,K)*AI(I,K)
X GI = GI - AR(J,K)*AI(I,K) + AI(J,K)*AR(I,K)
X 2400 CONTINUE
C
X JP1 = J + 1
X IF (L .LT. JP1) GO TO 2800
C
X DO 2600 K = JP1, L
X G = G + AR(K,J)*AR(I,K) - AI(K,J)*AI(I,K)
X GI = GI - AR(K,J)*AI(I,K) - AI(K,J)*AR(I,K)
X 2600 CONTINUE
X 2800 CONTINUE
X E(J) = G/H
X TAU(2,J) = GI/H
X F = F + E(J)*AR(I,J) - TAU(2,J)*AI(I,J)
X 3000 CONTINUE
C
X HH = F/(H+H)
X DO 3400 J = 1, L
X F = AR(I,J)
X G = E(J) - HH*F
X E(J) = G
X FI = -AI(I,J)
X GI = TAU(2,J) - HH*FI
X TAU(2,J) = -GI
C
X DO 3200 K = 1, J
X AR(J,K)=AR(J,K)-F*E(K)-G*AR(I,K)+FI*TAU(2,K)+GI*AI(I,K)
X AI(J,K)=AI(J,K)-F*TAU(2,K)-G*AI(I,K)-FI*E(K)-GI*AR(I,K)
X 3200 CONTINUE
X 3400 CONTINUE
C
X 3600 CONTINUE
X DO 3800 K = 1, L
X AR(I,K) = SCALE*AR(I,K)
X AI(I,K) = SCALE*AI(I,K)
X 3800 CONTINUE
C
X TAU(2,L) = -SI
X 4000 CONTINUE
X HH = D(I)
X D(I) = AR(I,I)
X AR(I,I) = HH
X AI(I,I) = SCALE*SQRT(H)
X 4200 CONTINUE
C
X RETURN
X END
X SUBROUTINE SUB029(GTEN)
X PARAMETER (NX=100,NY=100,NA=100)
X COMMON /DATA/
X 1 GXX(NX,NY), GXY(NX,NY), GYY(NX,NY), G(NX,NY),
X 1 JABC(NA,3), RTP(NA,3), C(3,NA), RP(3,NA),R, RM(3,NA), AM(NA),
X 1 RCM(3), EV(5), DR(3,5,NA),U(5,5),RGT(15),PARAM(10),XTEN(5,5)
X DIMENSION GTEN(5,5)
X
X PI = 3.1415926535898
X DX = NX
X DX = 2.*PI/DX
X DY = NY
X DY = 2.*PI/DY
X DO 3600 JX = 1, NX
X X = JX - (NX+1)/2
X X = X*DX
X DO 3400 JY = 1, 25
X Y = JY - (NY+1)/2
X Y = Y*DY
X DO 1000 K = 1, NA
X DR(1,1,K) = 0.
X DR(1,2,K) = RP(3,K)
X DR(1,3,K) = -RP(2,K)
X DR(2,1,K) = -RP(3,K)
X DR(2,2,K) = 0.
X DR(2,3,K) = RP(1,K)
X DR(3,1,K) = RP(2,K)
X DR(3,2,K) = -RP(1,K)
X DR(3,3,K) = 0.
X 1000 CONTINUE
X X = X + DX/6.
X X = X - 2.*DX/6.
X DO 1200 K = 1, NA
X DR(1,3,K) = (RP(1,K)-RM(1,K))*4./DX
X DR(2,3,K) = (RP(2,K)-RM(2,K))*4./DX
X DR(3,3,K) = (RP(3,K)-RM(3,K))*4./DX
X 1200 CONTINUE
X X = X - DX/6.
X X = X + 4.*DX/6.
X X = X - 2.*DX/6.
X DO 1400 K = 1, NA
X DR(1,4,K) = (RP(1,K)-RM(1,K))/2./DX
X DR(2,4,K) = (RP(2,K)-RM(2,K))/2./DX
X DR(3,4,K) = (RP(3,K)-RM(3,K))/2./DX
X 1400 CONTINUE
X Y = Y + DY/6.
X Y = Y - 2.*DY/6.
X DO 1600 K = 1, NA
X DR(1,2,K) = (RP(1,K)-RM(1,K))*4./DY
X DR(2,2,K) = (RP(2,K)-RM(2,K))*4./DY
X DR(3,2,K) = (RP(3,K)-RM(3,K))*4./DY
X 1600 CONTINUE
X Y = Y - DY/6.
X Y = Y + 4.*DY/6.
X Y = Y - 2.*DY/6.
X DO 1800 K = 1, NA
X DR(1,5,K) = (RP(1,K)-RM(1,K))/2./DY
X DR(2,5,K) = (RP(2,K)-RM(2,K))/2./DY
X DR(3,5,K) = (RP(3,K)-RM(3,K))/2./DY
X 1800 CONTINUE
X DO 2400 I = 1, 5
X DO 2200 J = I, 5
X S = 0.
X DO 2000 K = 1, NA
X S = S + AM(K)*(DR(1,I,K)*DR(1,J,K)+DR(2,I,K)*DR(2,J,K)+
X 1 DR(3,I,K)*DR(3,J,K))
X 2000 CONTINUE
X XTEN(I,J) = S
X 2200 CONTINUE
X 2400 CONTINUE
X DET = 1.
X DO 2600 I = 1, 5
X EV(I) = 505379.05/XTEN(I,I)
X DET = DET*XTEN(I,I)
X 2600 CONTINUE
X DO 3200 I = 1, 5
X DO 3000 J = I, 5
X S = 0.
X DO 2800 M = 1, 5
X S = S + U(I,M)*EV(M)*U(J,M)
X 2800 CONTINUE
X GTEN(I,J) = S
X 3000 CONTINUE
X 3200 CONTINUE
X GXX(JX,JY) = GTEN(4,4)
X GXY(JX,JY) = GTEN(4,5)
X GYY(JX,JY) = GTEN(5,5)
X G(JX,JY) = DET
X 3400 CONTINUE
X 3600 CONTINUE
X RETURN
X END
X SUBROUTINE SUB030(JMAX,IMAX,RESMI)
X PARAMETER (IM=1000,JM=100)
X DIMENSION RESMI(JMAX)
X COMMON /DATA/ PTD(IM,JM),RES(IM,JM),CFE(IM,JM)
X COMMON /DATA/ CFW(IM,JM),CFN(IM,JM),CFS(IM,JM)
X COMMON /DATA/ ZTD(IM,JM),COF(IM,JM)
X SOR = 3.14
X DO 1200 J = 1, JMAX
X DO 1000 I = 1, IMAX
X PTD(I,J) = PTD(I,J) + SOR*RES(I,J)
X 1000 CONTINUE
X 1200 CONTINUE
X
X DO 1800 J = 2, JMAX - 1
X RESMI(J) = 0.0
X DO 1400 I = 2, IMAX - 1
X RES(I,J) = COF(I,J)*(CFE(I,J)*(PTD(I+1,J)-PTD(I,J))+CFW(I,J)*(
X 1 PTD(I-1,J)-PTD(I,J))+CFN(I,J)*(PTD(I,J+1)-PTD(I,J))+CFS(I,J
X 2 )*(PTD(I,J-1)-PTD(I,J))-ZTD(I,J))
X 1400 CONTINUE
X DO 1600 I = 1, IMAX
X RESMI(J) = RESMI(J) + RES(I,J)*RES(I,J)
X 1600 CONTINUE
X 1800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB031
X PARAMETER ( JDIM=129,KDIM=129,LDIM=101,MDIM=129, ND=6, NV=5 )
X PARAMETER (LS=1,LE=101,KS=1,KE=129,KD=129,LD=101,MD=129)
C
X COMMON/DATA/ U12(MD),U13(MD),U14(MD),U15(MD),U23(MD),
X $ U24(MD),U25(MD),U34(MD),U35(MD),U45(MD),
X $ B11(MD),B21(MD),B31(MD),B41(MD),B51(MD),
X $ B22(MD),B32(MD),B42(MD),B52(MD),B33(MD),
X $ B43(MD),B53(MD),B44(MD),B54(MD),B55(MD),F(LD,KD,5)
X COMMON/DATA/ A(LD,KD,5,5), B(LD,KD,5,5), C(LD,KD,5,5)
X COMMON/DATA/ E(LDIM,5,5),Q(LDIM,5,5),FN(LDIM,5),S(LDIM,5,5)
X $ ,H(LDIM,KDIM,5,5),U(LDIM,KDIM,5,5)
X K = KS
X
X DO 1400 N = 1, 5
X DO 1200 M = 1, 5
X DO 1000 L = LS, LE
X E(L,N,M) = C(L,KE,N,M)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
C
X
X DO 1600 L = LS, LE
X B11(L) = 5.E0*B(L,K,1,1)
X U12(L) = B(L,K,1,2)*B11(L)
X U13(L) = B(L,K,1,3)*B11(L)
X U14(L) = B(L,K,1,4)*B11(L)
X U15(L) = B(L,K,1,5)*B11(L)
X B21(L) = B(L,K,2,1)
X B22(L) = 5.E0*(B(L,K,2,2)-B21(L)*U12(L))
X U23(L) = (B(L,K,2,3)-B21(L)*U13(L))*B22(L)
X U24(L) = (B(L,K,2,4)-B21(L)*U14(L))*B22(L)
X U25(L) = (B(L,K,2,5)-B21(L)*U15(L))*B22(L)
X B31(L) = B(L,K,3,1)
X B32(L) = B(L,K,3,2) - B31(L)*U12(L)
X B33(L) = 5.E0*((B(L,K,3,3)-B31(L)*U13(L))-B32(L)*U23(L))
X U34(L) = ((B(L,K,3,4)-B31(L)*U14(L))-B32(L)*U24(L))*B33(L)
X U35(L) = ((B(L,K,3,5)-B31(L)*U15(L))-B32(L)*U25(L))*B33(L)
X B41(L) = B(L,K,4,1)
X B42(L) = B(L,K,4,2) - B41(L)*U12(L)
X B43(L) = (B(L,K,4,3)-B41(L)*U13(L)) - B42(L)*U23(L)
X B44(L) = 5.E0*(((B(L,K,4,4)-B41(L)*U14(L))-B42(L)*U24(L))-B43(L)
X 1 *U34(L))
X U45(L) = (((B(L,K,4,5)-B41(L)*U15(L))-B42(L)*U25(L))-B43(L)*U35(
X 1 L))*B44(L)
X B51(L) = B(L,K,5,1)
X B52(L) = B(L,K,5,2) - B51(L)*U12(L)
X B53(L) = (B(L,K,5,3)-B51(L)*U13(L)) - B52(L)*U23(L)
X B54(L)=((B(L,K,5,4)-B51(L)*U14(L))-B52(L)*U24(L))-B53(L)*U34(L)
X B55(L) = 5.E0*((((B(L,K,5,5)-B51(L)*U15(L))-B52(L)*U25(L))-B53(L
X 1 )*U35(L))-B54(L)*U45(L))
X 1600 CONTINUE
C
X DO 1800 L = LS, LE
X D1 = B11(L)*F(L,K,1)
X D2 = B22(L)*(F(L,K,2)-B21(L)*D1)
X D3 = B33(L)*(F(L,K,3)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(F(L,K,4)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(F(L,K,5)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*D4)
X F(L,K,5) = D5
X F(L,K,4) = D4 - U45(L)*D5
X F(L,K,3) = D3 - U35(L)*D5 - U34(L)*F(L,K,4)
X F(L,K,2) = D2 - U25(L)*D5 - U24(L)*F(L,K,4) - U23(L)*F(L,K,3)
X F(L,K,1) = D1 - U15(L)*D5 - U14(L)*F(L,K,4) - U13(L)*F(L,K,3) -
X 1 U12(L)*F(L,K,2)
X 1800 CONTINUE
C
X DO 2200 M = 1, 5
X DO 2000 L = LS, LE
X D1 = B11(L)*C(L,K,1,M)
X D2 = B22(L)*(C(L,K,2,M)-B21(L)*D1)
X D3 = B33(L)*(C(L,K,3,M)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(C(L,K,4,M)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(C(L,K,5,M)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*
X 1 D4)
X U(L,K,5,M) = D5
X U(L,K,4,M) = D4 - U45(L)*D5
X U(L,K,3,M) = D3 - U35(L)*D5 - U34(L)*U(L,K,4,M)
X U(L,K,2,M)=D2-U25(L)*D5-U24(L)*U(L,K,4,M)-U23(L)*U(L,K,3,M)
X U(L,K,1,M) = D1 - U15(L)*D5 - U14(L)*U(L,K,4,M) - U13(L)*U(L,K
X 1 ,3,M) - U12(L)*U(L,K,2,M)
X 2000 CONTINUE
X 2200 CONTINUE
X
X DO 2600 M = 1, 5
X
X DO 2400 L = LS, LE
X D1 = B11(L)*A(L,K,1,M)
X D2 = B22(L)*(A(L,K,2,M)-B21(L)*D1)
X D3 = B33(L)*(A(L,K,3,M)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(A(L,K,4,M)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(A(L,K,5,M)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*
X 1 D4)
X H(L,K,5,M) = D5
X H(L,K,4,M) = D4 - U45(L)*D5
X H(L,K,3,M) = D3 - U35(L)*D5 - U34(L)*H(L,K,4,M)
X H(L,K,2,M)=D2-U25(L)*D5-U24(L)*H(L,K,4,M)-U23(L)*H(L,K,3,M)
X H(L,K,1,M) = D1 - U15(L)*D5 - U14(L)*H(L,K,4,M) - U13(L)*H(L,K
X 1 ,3,M) - U12(L)*H(L,K,2,M)
X 2400 CONTINUE
X 2600 CONTINUE
C
X
X DO 3400 N = 1, 5
X
X DO 2800 L = LS, LE
X FN(L,N) = F(L,KE,N) - E(L,N,1)*F(L,K,1) - E(L,N,2)*F(L,K,2) -
X 1 E(L,N,3)*F(L,K,3) - E(L,N,4)*F(L,K,4) - E(L,N,5)*F(L,K,5)
X 2800 CONTINUE
X
X DO 3200 M = 1, 5
X
X DO 3000 L = LS, LE
X Q(L,N,M) = B(L,KE,N,M) - E(L,N,1)*H(L,K,1,M) - E(L,N,2)*H(L,
X 1 K,2,M) - E(L,N,3)*H(L,K,3,M) - E(L,N,4)*H(L,K,4,M) - E(L,
X 2 N,5)*H(L,K,5,M)
X 3000 CONTINUE
X 3200 CONTINUE
X 3400 CONTINUE
C
X DO 7000 K = KS + 1, KE - 2
X I = K - 1
X
X DO 4200 N = 1, 5
X
X DO 3600 L = LS, LE
X F(L,K,N) = F(L,K,N) - A(L,K,N,1)*F(L,I,1) - A(L,K,N,2)*F(L,I
X 1 ,2) - A(L,K,N,3)*F(L,I,3) - A(L,K,N,4)*F(L,I,4) - A(L,K,N
X 2 ,5)*F(L,I,5)
X 3600 CONTINUE
C
X
X DO 4000 M = 1, 5
X
X DO 3800 L = LS, LE
X B(L,K,N,M) = B(L,K,N,M) - A(L,K,N,1)*U(L,I,1,M) - A(L,K,N,
X 1 2)*U(L,I,2,M) - A(L,K,N,3)*U(L,I,3,M) - A(L,K,N,4)*U(L,
X 2 I,4,M) - A(L,K,N,5)*U(L,I,5,M)
X S(L,N,M) = (-E(L,N,1)*U(L,I,1,M)) - E(L,N,2)*U(L,I,2,M) -
X 1 E(L,N,3)*U(L,I,3,M) - E(L,N,4)*U(L,I,4,M) - E(L,N,5)*U(
X 2 L,I,5,M)
X H(L,K,N,M) = (-A(L,K,N,1)*H(L,I,1,M)) - A(L,K,N,2)*H(L,I,2
X 1 ,M) - A(L,K,N,3)*H(L,I,3,M) - A(L,K,N,4)*H(L,I,4,M) - A
X 2 (L,K,N,5)*H(L,I,5,M)
X 3800 CONTINUE
X 4000 CONTINUE
X 4200 CONTINUE
C
X
X DO 4800 N = 1, 5
X
X DO 4600 M = 1, 5
X
X DO 4400 L = LS, LE
X E(L,N,M) = S(L,N,M)
X 4400 CONTINUE
X 4600 CONTINUE
X 4800 CONTINUE
C
X
X DO 5000 L = LS, LE
X B11(L) = 5.E0*B(L,K,1,1)
X U12(L) = B(L,K,1,2)*B11(L)
X U13(L) = B(L,K,1,3)*B11(L)
X U14(L) = B(L,K,1,4)*B11(L)
X U15(L) = B(L,K,1,5)*B11(L)
X B21(L) = B(L,K,2,1)
X B22(L) = 5.E0*(B(L,K,2,2)-B21(L)*U12(L))
X U23(L) = (B(L,K,2,3)-B21(L)*U13(L))*B22(L)
X U24(L) = (B(L,K,2,4)-B21(L)*U14(L))*B22(L)
X U25(L) = (B(L,K,2,5)-B21(L)*U15(L))*B22(L)
X B31(L) = B(L,K,3,1)
X B32(L) = B(L,K,3,2) - B31(L)*U12(L)
X B33(L) = 5.E0*((B(L,K,3,3)-B31(L)*U13(L))-B32(L)*U23(L))
X U34(L) = ((B(L,K,3,4)-B31(L)*U14(L))-B32(L)*U24(L))*B33(L)
X U35(L) = ((B(L,K,3,5)-B31(L)*U15(L))-B32(L)*U25(L))*B33(L)
X B41(L) = B(L,K,4,1)
X B42(L) = B(L,K,4,2) - B41(L)*U12(L)
X B43(L) = (B(L,K,4,3)-B41(L)*U13(L)) - B42(L)*U23(L)
X B44(L) = 5.E0*(((B(L,K,4,4)-B41(L)*U14(L))-B42(L)*U24(L))-B43(
X 1 L)*U34(L))
X U45(L) = (((B(L,K,4,5)-B41(L)*U15(L))-B42(L)*U25(L))-B43(L)*
X 1 U35(L))*B44(L)
X B51(L) = B(L,K,5,1)
X B52(L) = B(L,K,5,2) - B51(L)*U12(L)
X B53(L) = (B(L,K,5,3)-B51(L)*U13(L)) - B52(L)*U23(L)
X B54(L) = ((B(L,K,5,4)-B51(L)*U14(L))-B52(L)*U24(L)) - B53(L)*
X 1 U34(L)
X B55(L) = 5.E0*((((B(L,K,5,5)-B51(L)*U15(L))-B52(L)*U25(L))-B53
X 1 (L)*U35(L))-B54(L)*U45(L))
X 5000 CONTINUE
C
X
X
X DO 5200 L = LS, LE
X D1 = B11(L)*F(L,K,1)
X D2 = B22(L)*(F(L,K,2)-B21(L)*D1)
X D3 = B33(L)*(F(L,K,3)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(F(L,K,4)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(F(L,K,5)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*D4)
X F(L,K,5) = D5
X F(L,K,4) = D4 - U45(L)*D5
X F(L,K,3) = D3 - U35(L)*D5 - U34(L)*F(L,K,4)
X F(L,K,2) = D2 - U25(L)*D5 - U24(L)*F(L,K,4) - U23(L)*F(L,K,3)
X F(L,K,1) = D1 - U15(L)*D5 - U14(L)*F(L,K,4) - U13(L)*F(L,K,3)
X 1 - U12(L)*F(L,K,2)
X 5200 CONTINUE
C
X
X DO 5600 M = 1, 5
X
X DO 5400 L = LS, LE
X D1 = B11(L)*C(L,K,1,M)
X D2 = B22(L)*(C(L,K,2,M)-B21(L)*D1)
X D3 = B33(L)*(C(L,K,3,M)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(C(L,K,4,M)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(C(L,K,5,M)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)
X 1 *D4)
X U(L,K,5,M) = D5
X U(L,K,4,M) = D4 - U45(L)*D5
X U(L,K,3,M) = D3 - U35(L)*D5 - U34(L)*U(L,K,4,M)
X U(L,K,2,M)=D2-U25(L)*D5-U24(L)*U(L,K,4,M)-U23(L)*U(L,K,3,M)
X U(L,K,1,M) = D1 - U15(L)*D5 - U14(L)*U(L,K,4,M) - U13(L)*U(L
X 1 ,K,3,M) - U12(L)*U(L,K,2,M)
X 5400 CONTINUE
X 5600 CONTINUE
C
X
X DO 6000 M = 1, 5
X
X DO 5800 L = LS, LE
X D1 = B11(L)*H(L,K,1,M)
X D2 = B22(L)*(H(L,K,2,M)-B21(L)*D1)
X D3 = B33(L)*(H(L,K,3,M)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(H(L,K,4,M)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(H(L,K,5,M)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)
X 1 *D4)
X H(L,K,5,M) = D5
X H(L,K,4,M) = D4 - U45(L)*D5
X H(L,K,3,M) = D3 - U35(L)*D5 - U34(L)*H(L,K,4,M)
X H(L,K,2,M)=D2-U25(L)*D5-U24(L)*H(L,K,4,M)-U23(L)*H(L,K,3,M)
X H(L,K,1,M) = D1 - U15(L)*D5 - U14(L)*H(L,K,4,M) - U13(L)*H(L
X 1 ,K,3,M) - U12(L)*H(L,K,2,M)
X 5800 CONTINUE
X 6000 CONTINUE
C
X
X
X DO 6800 N = 1, 5
X
X DO 6200 L = LS, LE
X FN(L,N) = FN(L,N) - E(L,N,1)*F(L,K,1) - E(L,N,2)*F(L,K,2) -
X 1 E(L,N,3)*F(L,K,3) - E(L,N,4)*F(L,K,4) - E(L,N,5)*F(L,K,5)
X 6200 CONTINUE
X
X DO 6600 M = 1, 5
X
X DO 6400 L = LS, LE
X Q(L,N,M) = Q(L,N,M) - E(L,N,1)*H(L,K,1,M) - E(L,N,2)*H(L,K
X 1 ,2,M) - E(L,N,3)*H(L,K,3,M) - E(L,N,4)*H(L,K,4,M) - E(L
X 2 ,N,5)*H(L,K,5,M)
X 6400 CONTINUE
X 6600 CONTINUE
X 6800 CONTINUE
X 7000 CONTINUE
C
X K = KE - 1
X I = K - 1
X
X DO 7800 N = 1, 5
X
X DO 7200 L = LS, LE
X F(L,K,N) = F(L,K,N) - A(L,K,N,1)*F(L,I,1) - A(L,K,N,2)*F(L,I,2
X 1 ) - A(L,K,N,3)*F(L,I,3) - A(L,K,N,4)*F(L,I,4) - A(L,K,N,5)*
X 2 F(L,I,5)
X 7200 CONTINUE
X
X DO 7600 M = 1, 5
X
X DO 7400 L = LS, LE
X B(L,K,N,M) = B(L,K,N,M) - A(L,K,N,1)*U(L,I,1,M) - A(L,K,N,2)
X 1 *U(L,I,2,M) - A(L,K,N,3)*U(L,I,3,M) - A(L,K,N,4)*U(L,I,4,
X 2 M) - A(L,K,N,5)*U(L,I,5,M)
X S(L,N,M) = (-E(L,N,1)*U(L,I,1,M)) - E(L,N,2)*U(L,I,2,M) - E(
X 1 L,N,3)*U(L,I,3,M) - E(L,N,4)*U(L,I,4,M) - E(L,N,5)*U(L,I,
X 2 5,M) + A(L,KE,N,M)
X H(L,K,N,M) = (-A(L,K,N,1)*H(L,I,1,M)) - A(L,K,N,2)*H(L,I,2,M
X 1 ) - A(L,K,N,3)*H(L,I,3,M) - A(L,K,N,4)*H(L,I,4,M) - A(L,K
X 2 ,N,5)*H(L,I,5,M) + C(L,K,N,M)
X 7400 CONTINUE
X 7600 CONTINUE
X 7800 CONTINUE
C
X
X
X DO 8400 N = 1, 5
X
X DO 8200 M = 1, 5
X
X DO 8000 L = LS, LE
X E(L,N,M) = S(L,N,M)
X 8000 CONTINUE
X 8200 CONTINUE
X 8400 CONTINUE
C
X
X DO 8600 L = LS, LE
X B11(L) = 5.E0*B(L,K,1,1)
X U12(L) = B(L,K,1,2)*B11(L)
X U13(L) = B(L,K,1,3)*B11(L)
X U14(L) = B(L,K,1,4)*B11(L)
X U15(L) = B(L,K,1,5)*B11(L)
X B21(L) = B(L,K,2,1)
X B22(L) = 5.E0*(B(L,K,2,2)-B21(L)*U12(L))
X U23(L) = (B(L,K,2,3)-B21(L)*U13(L))*B22(L)
X U24(L) = (B(L,K,2,4)-B21(L)*U14(L))*B22(L)
X U25(L) = (B(L,K,2,5)-B21(L)*U15(L))*B22(L)
X B31(L) = B(L,K,3,1)
X B32(L) = B(L,K,3,2) - B31(L)*U12(L)
X B33(L) = 5.E0*((B(L,K,3,3)-B31(L)*U13(L))-B32(L)*U23(L))
X U34(L) = ((B(L,K,3,4)-B31(L)*U14(L))-B32(L)*U24(L))*B33(L)
X U35(L) = ((B(L,K,3,5)-B31(L)*U15(L))-B32(L)*U25(L))*B33(L)
X B41(L) = B(L,K,4,1)
X B42(L) = B(L,K,4,2) - B41(L)*U12(L)
X B43(L) = (B(L,K,4,3)-B41(L)*U13(L)) - B42(L)*U23(L)
X B44(L) = 5.E0*(((B(L,K,4,4)-B41(L)*U14(L))-B42(L)*U24(L))-B43(L)
X 1 *U34(L))
X U45(L) = (((B(L,K,4,5)-B41(L)*U15(L))-B42(L)*U25(L))-B43(L)*U35(
X 1 L))*B44(L)
X B51(L) = B(L,K,5,1)
X B52(L) = B(L,K,5,2) - B51(L)*U12(L)
X B53(L) = (B(L,K,5,3)-B51(L)*U13(L)) - B52(L)*U23(L)
X B54(L)=((B(L,K,5,4)-B51(L)*U14(L))-B52(L)*U24(L))-B53(L)*U34(L)
X B55(L) = 5.E0*((((B(L,K,5,5)-B51(L)*U15(L))-B52(L)*U25(L))-B53(L
X 1 )*U35(L))-B54(L)*U45(L))
X 8600 CONTINUE
C
X DO 8800 L = LS, LE
X D1 = B11(L)*F(L,K,1)
X D2 = B22(L)*(F(L,K,2)-B21(L)*D1)
X D3 = B33(L)*(F(L,K,3)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(F(L,K,4)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(F(L,K,5)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*D4)
X F(L,K,5) = D5
X F(L,K,4) = D4 - U45(L)*D5
X F(L,K,3) = D3 - U35(L)*D5 - U34(L)*F(L,K,4)
X F(L,K,2) = D2 - U25(L)*D5 - U24(L)*F(L,K,4) - U23(L)*F(L,K,3)
X F(L,K,1) = D1 - U15(L)*D5 - U14(L)*F(L,K,4) - U13(L)*F(L,K,3) -
X 1 U12(L)*F(L,K,2)
X 8800 CONTINUE
C
X
X DO 9200 M = 1, 5
X
X DO 9000 L = LS, LE
X D1 = B11(L)*H(L,K,1,M)
X D2 = B22(L)*(H(L,K,2,M)-B21(L)*D1)
X D3 = B33(L)*(H(L,K,3,M)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(H(L,K,4,M)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(H(L,K,5,M)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*
X 1 D4)
X H(L,K,5,M) = D5
X H(L,K,4,M) = D4 - U45(L)*D5
X H(L,K,3,M) = D3 - U35(L)*D5 - U34(L)*H(L,K,4,M)
X H(L,K,2,M)=D2-U25(L)*D5-U24(L)*H(L,K,4,M)-U23(L)*H(L,K,3,M)
X H(L,K,1,M) = D1 - U15(L)*D5 - U14(L)*H(L,K,4,M) - U13(L)*H(L,K
X 1 ,3,M) - U12(L)*H(L,K,2,M)
X 9000 CONTINUE
X 9200 CONTINUE
X
X DO 10000 N = 1, 5
X
X DO 9400 L = LS, LE
X FN(L,N) = FN(L,N) - E(L,N,1)*F(L,K,1) - E(L,N,2)*F(L,K,2) - E(
X 1 L,N,3)*F(L,K,3) - E(L,N,4)*F(L,K,4) - E(L,N,5)*F(L,K,5)
X 9400 CONTINUE
X
X DO 9800 M = 1, 5
X
X DO 9600 L = LS, LE
X Q(L,N,M) = Q(L,N,M) - E(L,N,1)*H(L,K,1,M) - E(L,N,2)*H(L,K,2
X 1 ,M) - E(L,N,3)*H(L,K,3,M) - E(L,N,4)*H(L,K,4,M) - E(L,N,5
X 2 )*H(L,K,5,M)
X 9600 CONTINUE
X 9800 CONTINUE
X10000 CONTINUE
C
X K = KE
C
X
X DO 10200 L = LS, LE
X B11(L) = 5.E0*Q(L,1,1)
X U12(L) = Q(L,1,2)*B11(L)
X U13(L) = Q(L,1,3)*B11(L)
X U14(L) = Q(L,1,4)*B11(L)
X U15(L) = Q(L,1,5)*B11(L)
X B21(L) = Q(L,2,1)
X B22(L) = 5.E0*(Q(L,2,2)-B21(L)*U12(L))
X U23(L) = (Q(L,2,3)-B21(L)*U13(L))*B22(L)
X U24(L) = (Q(L,2,4)-B21(L)*U14(L))*B22(L)
X U25(L) = (Q(L,2,5)-B21(L)*U15(L))*B22(L)
X B31(L) = Q(L,3,1)
X B32(L) = Q(L,3,2) - B31(L)*U12(L)
X B33(L) = 5.E0*((Q(L,3,3)-B31(L)*U13(L))-B32(L)*U23(L))
X U34(L) = ((Q(L,3,4)-B31(L)*U14(L))-B32(L)*U24(L))*B33(L)
X U35(L) = ((Q(L,3,5)-B31(L)*U15(L))-B32(L)*U25(L))*B33(L)
X B41(L) = Q(L,4,1)
X B42(L) = Q(L,4,2) - B41(L)*U12(L)
X B43(L) = (Q(L,4,3)-B41(L)*U13(L)) - B42(L)*U23(L)
X B44(L) = 5.E0*(((Q(L,4,4)-B41(L)*U14(L))-B42(L)*U24(L))-B43(L)*
X 1 U34(L))
X U45(L) = (((Q(L,4,5)-B41(L)*U15(L))-B42(L)*U25(L))-B43(L)*U35(L)
X 1 )*B44(L)
X B51(L) = Q(L,5,1)
X B52(L) = Q(L,5,2) - B51(L)*U12(L)
X B53(L) = (Q(L,5,3)-B51(L)*U13(L)) - B52(L)*U23(L)
X B54(L)=((Q(L,5,4)-B51(L)*U14(L))-B52(L)*U24(L))-B53(L)*U34(L)
X B55(L) = 5.E0*((((Q(L,5,5)-B51(L)*U15(L))-B52(L)*U25(L))-B53(L)*
X 1 U35(L))-B54(L)*U45(L))
X10200 CONTINUE
C
X
X DO 10400 L = LS, LE
X D1 = B11(L)*FN(L,1)
X D2 = B22(L)*(FN(L,2)-B21(L)*D1)
X D3 = B33(L)*(FN(L,3)-B31(L)*D1-B32(L)*D2)
X D4 = B44(L)*(FN(L,4)-B41(L)*D1-B42(L)*D2-B43(L)*D3)
X D5 = B55(L)*(FN(L,5)-B51(L)*D1-B52(L)*D2-B53(L)*D3-B54(L)*D4)
X F(L,K,5) = D5
X F(L,K,4) = D4 - U45(L)*D5
X F(L,K,3) = D3 - U35(L)*D5 - U34(L)*F(L,K,4)
X F(L,K,2) = D2 - U25(L)*D5 - U24(L)*F(L,K,4) - U23(L)*F(L,K,3)
X F(L,K,1) = D1 - U15(L)*D5 - U14(L)*F(L,K,4) - U13(L)*F(L,K,3) -
X 1 U12(L)*F(L,K,2)
X10400 CONTINUE
X
X K = KE - 1
X
X DO 10800 N = 1, 5
X
X DO 10600 L = LS, LE
X F(L,K,N) = F(L,K,N) - H(L,K,N,1)*F(L,KE,1) - H(L,K,N,2)*F(L,KE
X 1 ,2) - H(L,K,N,3)*F(L,KE,3) - H(L,K,N,4)*F(L,KE,4) - H(L,K,N
X 2 ,5)*F(L,KE,5)
X10600 CONTINUE
X10800 CONTINUE
C
X
X DO 11400 KK = KS, KE - 2
X K = KS + KE - 2 - KK
X I = K + 1
X
X DO 11200 N = 1, 5
X
X DO 11000 L = LS, LE
X F(L,K,N) = F(L,K,N) - U(L,K,N,1)*F(L,I,1) - U(L,K,N,2)*F(L,I
X 1 ,2) - U(L,K,N,3)*F(L,I,3) - U(L,K,N,4)*F(L,I,4) - U(L,K,N
X 2 ,5)*F(L,I,5) - H(L,K,N,1)*F(L,KE,1) - H(L,K,N,2)*F(L,KE,2
X 3 ) - H(L,K,N,3)*F(L,KE,3) - H(L,K,N,4)*F(L,KE,4) - H(L,K,N
X 4 ,5)*F(L,KE,5)
X11000 CONTINUE
X11200 CONTINUE
X11400 CONTINUE
X
X RETURN
X END
X SUBROUTINE SUB032
X COMMON/DATA/Q(120,23,30,6)
X COMMON/DATA/
X * XX(120,23,30),XY(120,23,30),XZ(120,23,30),
X * YX(120,23,30),YY(120,23,30),YZ(120,23,30),
X * ZX(120,23,30),ZY(120,23,30),ZZ(120,23,30)
X COMMON/DATA/S(120,23,30,5),VARDT(120,23,30)
X COMMON /DATA/ SPECT(120,23,30),COEF(120,23,30)
X COMMON /DATA/ CC(120,120)
X *, WR1(120,120),WR2(120,120)
X *, Q6(120,120),FD(5)
X DATA JMAX/120/,KMAX/23/LMAX/30/,JM/119/KM/22/LM/29/
C
X DT = .5
X GAMMA = .6
X GAMI = .7
X FSMACH = .8
X ALP = DT
X DIS2 = DT
X DIS4 = DIS2
X CNBR = .5
X PI = 3.14
X EPS2 = DIS2*DT
X EPS4 = DIS4*64.*DT
C
X DO 1400 L = 1, LMAX
X DO 1200 K = 1, KMAX
X DO 1000 J = 1, JMAX
X COEF(J,K,L) = 0.
X SPECT(J,K,L) = 1.
X Q(J,K,L,1) = Q(J,K,L,1)*Q(J,K,L,6)
X Q(J,K,L,2) = Q(J,K,L,2)*Q(J,K,L,6)
X Q(J,K,L,3) = Q(J,K,L,3)*Q(J,K,L,6)
X Q(J,K,L,4) = Q(J,K,L,4)*Q(J,K,L,6)
X Q(J,K,L,5) = Q(J,K,L,5)*Q(J,K,L,6)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
C
X DO 2000 L = 1, LMAX
X DO 1800 K = 1, KMAX
X DO 1600 J = 1, JMAX
X RI = Q(J,K,L,1)
X U = Q(J,K,L,2)*RI
X V = Q(J,K,L,3)*RI
X W = Q(J,K,L,4)*RI
X SNDSP2 = GAMI*GAMMA*(Q(J,K,L,5)*RI-.5*(U*U+V*V+W*W))
X SIGA = ABS(U*XX(J,K,L)+V*XY(J,K,L)+W*XZ(J,K,L)) + SQRT(
X 1 SNDSP2*(XX(J,K,L)**2+XY(J,K,L)**2+XZ(J,K,L)**2))
X SIGB = ABS(U*YX(J,K,L)+V*YY(J,K,L)+W*YZ(J,K,L)) + SQRT(
X 1 SNDSP2*(YX(J,K,L)**2+YY(J,K,L)**2+YZ(J,K,L)**2))
X SIGC = ABS(U*ZX(J,K,L)+V*ZY(J,K,L)+W*ZZ(J,K,L)) + SQRT(
X 1 SNDSP2*(ZX(J,K,L)**2+ZY(J,K,L)**2+ZZ(J,K,L)**2))
X SPECT(J,K,L) = SIGA + SIGB + SIGC
X 1600 CONTINUE
X 1800 CONTINUE
X 2000 CONTINUE
C
X DO 7000 L = 2, LM
C
X DO 2400 J = 1, JM + 1
X DO 2200 K = 1, KM + 1
X Q6(J,K) = Q(J,K,L,6)
X 2200 CONTINUE
X 2400 CONTINUE
C
X DO 4600 N = 1, 5
C
X DO 2800 J = 1, JM
X JPL = J + 1
X DO 2600 K = 2, KM
X WR1(J,K) = Q(JPL,K,L,N) - Q(J,K,L,N)
X 2600 CONTINUE
X 2800 CONTINUE
C
X DO 3000 K = 2, KM
X WR1(JMAX,K) = WR1(JM,K)
X 3000 CONTINUE
C
X DO 3400 J = 2, JM
X JPL = J + 1
X JMI = J - 1
X DO 3200 K = 2, KM
X WR2(J,K) = WR1(JPL,K) - 2.*WR1(J,K) + WR1(JMI,K)
X 3200 CONTINUE
X 3400 CONTINUE
C
X DO 3600 K = 2, KM
X WR2(1,K) = Q(3,K,L,N) - 2.*Q(2,K,L,N) + Q(1,K,L,N)
X WR2(JMAX,K) = 0.
X 3600 CONTINUE
C
X DO 4000 J = 1, JM
X JPL = J + 1
X DO 3800 K = 2, KM
X FIL = SPECT(JPL,K,L)*Q6(JPL,K) + SPECT(J,K,L)*Q6(J,K)
X COEF2 = EPS2*COEF(J,K,L)*FIL
X COEF4 = EPS4*FIL
X CC(J,K) = COEF2*WR1(J,K) - COEF4*WR2(J,K)
X 3800 CONTINUE
X 4000 CONTINUE
C
X DO 4400 J = 2, JM
X JMI = J - 1
X DO 4200 K = 2, KM
X S(J,K,L,N) = S(J,K,L,N) + (CC(J,K)-CC(JMI,K))
X 4200 CONTINUE
X 4400 CONTINUE
C
X 4600 CONTINUE
C
X DO 6800 N = 1, 5
C
X DO 5000 K = 1, KM
X KPL = K + 1
X DO 4800 J = 2, JM
X WR1(J,K) = Q(J,KPL,L,N) - Q(J,K,L,N)
X 4800 CONTINUE
X 5000 CONTINUE
C
X DO 5200 J = 2, JM
X WR1(J,KMAX) = WR1(J,KM)
X 5200 CONTINUE
C
X DO 5600 K = 2, KM
X KPL = K + 1
X KMI = K - 1
X DO 5400 J = 2, JM
X WR2(J,K) = WR1(J,KPL) - 2.*WR1(J,K) + WR1(J,KMI)
X 5400 CONTINUE
X 5600 CONTINUE
C
X DO 5800 J = 2, JM
X WR2(J,1) = Q(J,3,L,N) - 2.*Q(J,2,L,N) + Q(J,1,L,N)
X WR2(J,KMAX) = 0.
X 5800 CONTINUE
C
X DO 6200 K = 1, KM
X DO 6000 J = 2, JM
C
X FIL = SPECT(J,K+1,L)*Q6(J,K+1) + SPECT(J,K,L)*Q6(J,K)
X COEF2 = EPS2*COEF(J,K,L)*FIL
X COEF4 = EPS4*FIL
X CC(J,K) = COEF2*WR1(J,K) - COEF4*WR2(J,K)
X 6000 CONTINUE
X 6200 CONTINUE
C
X DO 6600 K = 2, KM
X DO 6400 J = 2, JM
X S(J,K,L,N) = S(J,K,L,N) + (CC(J,K)-CC(J,K-1))
X 6400 CONTINUE
X 6600 CONTINUE
C
X 6800 CONTINUE
C
C END LOOP IN L
C
X 7000 CONTINUE
C
X DO 9800 K = 2, KM
C
X DO 7400 L = 1, LM + 1
X DO 7200 J = 2, JM
X Q6(J,L) = Q(J,K,L,6)
X 7200 CONTINUE
X 7400 CONTINUE
C
X DO 9600 N = 1, 5
C
X DO 7800 L = 1, LM
X LPL = L + 1
X DO 7600 J = 2, JM
X WR1(J,L) = Q(J,K,LPL,N) - Q(J,K,L,N)
X 7600 CONTINUE
X 7800 CONTINUE
C
X DO 8000 J = 2, JM
X WR1(J,LMAX) = WR1(J,LM)
X 8000 CONTINUE
C
X DO 8400 L = 2, LM
X LPL = L + 1
X LMI = L - 1
X DO 8200 J = 2, JM
X WR2(J,L) = WR1(J,LPL) - 2.*WR1(J,L) + WR1(J,LMI)
X 8200 CONTINUE
X 8400 CONTINUE
C
X DO 8600 J = 2, JM
X WR2(J,1) = Q(J,K,3,N) - 2.*Q(J,K,2,N) + Q(J,K,1,N)
X WR2(J,LMAX) = 0.
X 8600 CONTINUE
C
X DO 9000 L = 1, LM
X DO 8800 J = 2, JM
C
X FIL = SPECT(J,K,L+1)*Q6(J,L+1) + SPECT(J,K,L)*Q6(J,L)
X COEF2 = EPS2*COEF(J,K,L)*FIL
X COEF4 = EPS4*FIL
X CC(J,L) = COEF2*WR1(J,L) - COEF4*WR2(J,L)
X 8800 CONTINUE
X 9000 CONTINUE
C
X DO 9400 L = 2, LM
X DO 9200 J = 2, JM
X S(J,K,L,N) = S(J,K,L,N) + (CC(J,L)-CC(J,L-1))
X 9200 CONTINUE
X 9400 CONTINUE
C
X 9600 CONTINUE
C
X 9800 CONTINUE
C
X DO 10400 L = 1, LMAX
X DO 10200 K = 1, KMAX
X DO 10000 J = 1, JMAX
X RJ = Q(J,K,L,6)
X Q(J,K,L,1) = Q(J,K,L,1)*RJ
X Q(J,K,L,2) = Q(J,K,L,2)*RJ
X Q(J,K,L,3) = Q(J,K,L,3)*RJ
X Q(J,K,L,4) = Q(J,K,L,4)*RJ
X Q(J,K,L,5) = Q(J,K,L,5)*RJ
X10000 CONTINUE
X10200 CONTINUE
X10400 CONTINUE
C
X RETURN
X END
X SUBROUTINE SUB033(IRECT,MSR,NSV,ILOC,IRTL,ISEG,NSN)
X PARAMETER (JMAX=1000)
X DIMENSION IRECT(4,1),MSR(1),NSV(1),ILOC(1),
X 1 IRTL(1),ISEG(1)
X COMMON /DATA/ FDAT(5,JMAX)
X COMMON /DATA/ X(3,JMAX),E(JMAX),STF(JMAX)
X COMMON /DATA/ FRIC(JMAX),AMX,AMY,AMZ,N1,N2,N3
X COMMON /DATA/ XX1(JMAX),XX2(JMAX),XX3(JMAX),H(4)
X DIMENSION IX(4)
X REAL N1,N2,N3
X SS = 3.14
X TT = .5
X DT2 = .75
X FCOEFF = FRIC(1)**2 + FRIC(2)**2 + FRIC(3)**2
X DO 2800 II = 1, NSN
X I = NSV(II)
X J = ILOC(II)
X K = MSR(J)
X L = IRTL(II)
X DO 1000 JJ = 1, 4
X NN = IRECT(JJ,L)
X IX(JJ) = NN
X XX1(JJ) = X(1,NN)
X XX2(JJ) = X(2,NN)
X XX3(JJ) = X(3,NN)
X 1000 CONTINUE
X XS1 = X(1,I)
X YS1 = X(2,I)
X ZS1 = X(3,I)
X IF (K .NE. IX(1)) GO TO 1200
X K1 = 1
X K2 = 2
X K3 = 4
X GO TO 1800
X 1200 CONTINUE
X IF (K .NE. IX(2)) GO TO 1400
X K1 = 2
X K2 = 3
X K3 = 1
X GO TO 1800
X 1400 CONTINUE
X IF (K .NE. IX(3)) GO TO 1600
X K1 = 3
X K2 = 4
X K3 = 2
X IF (IX(3) .EQ. IX(4)) K2 = 1
X GO TO 1800
X 1600 CONTINUE
X IF (K .NE. IX(4)) GO TO 1800
X K1 = 4
X K2 = 1
X K3 = 3
X 1800 CONTINUE
X IERR = 0
X I3 = 3*I
X I2 = I3 - 1
X I1 = I2 - 1
X ANS = N1*(XS1-AMX) + N2*(YS1-AMY) + N3*(ZS1-AMZ)
X FNI = ANS*STF(L)
X FXI = N1*FNI
X FYI = N2*FNI
X FZI = N3*FNI
X IF (FCOEFF .EQ. 0.0) GO TO 2400
X JJ = ISEG(II)
X IF (JJ .NE. 0) GO TO 2000
X ISEG(II) = L
X FDAT(1,II) = SS
X FDAT(2,II) = TT
X GO TO 2400
X 2000 CONTINUE
X TP = .25*(1.0+FDAT(2,II))
X TM = .25*(1.0-FDAT(2,II))
X SP = 1.0 + FDAT(1,II)
X SM = 1.0 - FDAT(1,II)
X H1 = TM*SM
X H2 = TM*SP
X H3 = TP*SP
X H4 = TP*SM
X NN1 = IRECT(1,JJ)
X NN2 = IRECT(2,JJ)
X NN3 = IRECT(3,JJ)
X NN4 = IRECT(4,JJ)
X DX = AMX - H1*X(1,NN1) - H2*X(1,NN2) - H3*X(1,NN3) - H4*X(1,NN4)
X DY = AMY - H1*X(2,NN1) - H2*X(2,NN2) - H3*X(2,NN3) - H4*X(2,NN4)
X DZ = AMZ - H1*X(3,NN1) - H2*X(3,NN2) - H3*X(3,NN3) - H4*X(3,NN4)
X VEL = SQRT(DX**2+DY**2+DZ**2)/AMAX1(1.E-20,DT2)
X FDAT(3,II) = FDAT(3,II) + STF(L)*DX
X FDAT(4,II) = FDAT(4,II) + STF(L)*DY
X FDAT(5,II) = FDAT(5,II) + STF(L)*DZ
X PROJ = FDAT(3,II)*N1 + FDAT(4,II)*N2 + FDAT(5,II)*N3
X FDAT(3,II) = FDAT(3,II) - PROJ*N1
X FDAT(4,II) = FDAT(4,II) - PROJ*N2
X FDAT(5,II) = FDAT(5,II) - PROJ*N3
X FMAX = -(FRIC(2)+(FRIC(1)-FRIC(2))*EXP((-FRIC(3)*VEL)))*FNI
X FMAG = SQRT(FDAT(3,II)**2+FDAT(4,II)**2+FDAT(5,II)**2)
X IF (FMAX.GE.FMAG .OR. FMAG.EQ.0.) GO TO 2200
X IF (FMAG .NE. 0) SCLF = FMAX/FMAG
X FDAT(3,II) = SCLF*FDAT(3,II)
X FDAT(4,II) = SCLF*FDAT(4,II)
X FDAT(5,II) = SCLF*FDAT(5,II)
X 2200 CONTINUE
X FXI = FXI + FDAT(3,II)
X FYI = FYI + FDAT(4,II)
X FZI = FZI + FDAT(5,II)
X ISEG(II) = L
X FDAT(1,II) = SS
X FDAT(2,II) = TT
X 2400 CONTINUE
X DO 2600 JJ = 1, 4
X J3 = 3*IX(JJ)
X J2 = J3 - 1
X J1 = J2 - 1
X E(J1) = E(J1) + FXI*H(JJ)
X E(J2) = E(J2) + FYI*H(JJ)
X E(J3) = E(J3) + FZI*H(JJ)
X 2600 CONTINUE
X E(I1) = E(I1) - FXI
X E(I2) = E(I2) - FYI
X E(I3) = E(I3) - FZI
X 2800 CONTINUE
X RETURN
X END
X SUBROUTINE SUB034(LMAX,KMAX)
X PARAMETER (RADIUS = 4.0)
X PARAMETER (DENSTY = 5.0)
X PARAMETER (VSCALE = 2.0)
X PARAMETER (KMESH = 100)
X PARAMETER (LMESH = 100)
X PARAMETER (CYCLES = 100)
X PARAMETER (TIME = 1.0)
X PARAMETER (NOPRNT = 1)
X PARAMETER (IVREG = 64)
X PARAMETER (KKMAX = KMESH + 1)
X PARAMETER (LLMAX = LMESH + 1)
X PARAMETER (NCMAX = KKMAX + LLMAX)
X PARAMETER (NZONM = KKMAX * LLMAX)
X PARAMETER (FMEM10 = -1.E-10)
X PARAMETER (F1EM10 = 1.E-10)
X PARAMETER (F2EM10 = 2.E-10)
X PARAMETER (F1E10 = 1.E10)
X PARAMETER (F1EM4 = 1.E-4)
X PARAMETER (F1EM12 = 1.E-12)
X PARAMETER (F1EM5 = 1.E-5)
X PARAMETER (F1EM6 = 1.E-6)
X PARAMETER (F1EM36 = 1.E-36)
X PARAMETER (F1EM8 = 1.E-8)
X PARAMETER (IMXSES = 5000)
X PARAMETER (IMMAX = 1)
X PARAMETER (NULL = 0)
X PARAMETER (IENRGY = 1)
X PARAMETER (IDEDT = 2)
X PARAMETER (IDEDR = 4)
X PARAMETER (IPRESS = 8)
X PARAMETER (IDPDT = 16)
X PARAMETER (IDPDR = 32)
X PARAMETER (IDNSTY = 64)
X PARAMETER (ITHETA = 128)
X INTEGER
X . IKQN ,
X . ILQN
X COMMON /DATA/
X . DDOR (KKMAX,LLMAX) ,
X . DDUAC (KKMAX,LLMAX) ,
X . DDUBC (KKMAX,LLMAX) ,
X . DDUMIN (KKMAX,LLMAX) ,
X . DUAC (KKMAX,LLMAX) ,
X . DUBC (KKMAX,LLMAX)
X COMMON/DATA/
X . CNDN , CNUP ,
X . CSTOP , CYCLE ,
X . DCNDN , DCNUP , DELNDN , DELNUP ,
X . DTAN , DTCN ,
X . DTEN , DTMAXN ,
X . DTMIN , DTN , DTNDN ,
X . DTNUP , DTQN ,
X . ETEST ,
X . RXDTA , RXDTC ,
X . RXDTEN , RXDTQ ,
X . THFLOR ,
X . TN ,
X . TNDN ,
X . TNUP ,
X . TSTEP , TSTOP
X COMMON/MASKS/
X . IFB , IFE , MASKIF ,
X . IMB , IME , MASKIM ,
X . IHB , IHE , MASKIH ,
X . ICE
X COMMON/BITFLG/
X . MSKIMZ, MSKF15, MSKMBK, MSKMK2,
X . MSKUKK, MSKUKC, MSKMBL, MSKML2, MSKULL, MSKULC,
X . MSKAMK, MSKAML, MSKHMR, MSKHMZ,
X . MSKTZL, MSKTZK,
X . MKIMZ, MKF15, MKMBK, MKMK2,
X . MKUKK, MKUKC, MKMBL, MKML2, MKULL, MKULC,
X . MKAMK, MKAML, MKHMR, MKHMZ,
X . MKTZL, MKTZK
X COMMON/MASKS/
X . MASKF1 , MASKF2 , MASKF3 , MASKF4
X COMMON /DATA/
X . FIT (KKMAX,LLMAX) ,
X . RT (KKMAX,LLMAX) ,
X . ZT (KKMAX,LLMAX) ,
X . AMT (KKMAX,LLMAX) ,
X . TT (KKMAX,LLMAX)
X COMMON /DATA/
X . RTH (KKMAX,LLMAX) ,
X . ZTH (KKMAX,LLMAX) ,
X . TTCH (KKMAX,LLMAX) ,
X . FJTCH (KKMAX,LLMAX) ,
X . ALR (KKMAX,LLMAX) ,
X . ALZ (KKMAX,LLMAX) ,
X . AKR (KKMAX,LLMAX) ,
X . AKZ (KKMAX,LLMAX) ,
X . DLRRCH (KKMAX,LLMAX) ,
X . DKRRCH (KKMAX,LLMAX)
X COMMON /DATA/
X . ET (KKMAX,LLMAX) ,
X . THAT (KKMAX,LLMAX) ,
X . PT (KKMAX,LLMAX) ,
X . UT (KKMAX,LLMAX) ,
X . VT (KKMAX,LLMAX)
X COMMON /DATA/
X . THCT (KKMAX,LLMAX) ,
X . DTHT (KKMAX,LLMAX) ,
X . FJT (KKMAX,LLMAX) ,
X . FJOIT (KKMAX,LLMAX) ,
X . Q1T (KKMAX,LLMAX) ,
X . Q2T (KKMAX,LLMAX) ,
X . Q3T (KKMAX,LLMAX) ,
X . Q4T (KKMAX,LLMAX) ,
X . DESRC (KKMAX,LLMAX) ,
X . DET (KKMAX,LLMAX)
X COMMON /DATA/
X . AIF3 (NCMAX) ,
X . XIUKK (NCMAX) ,
X . XIUKKM (NCMAX) ,
X . XIUKKC (NCMAX) ,
X . XIULL (NCMAX) ,
X . XIULLC (NCMAX) ,
X . DNDTC (NCMAX)
X INDMAX(N,R,I) = ISAMAX(N,R,I)
X* SEARCH(IM,Y,IY,N,X,IX,J,D,F) = SRCHDF(IM,Y,IY,N,X,IX,J,D,F)
X DDUF(A,B,C,Z1,Z2)=ABS(A-B)*Z1+ABS(B-C)*Z2
X RCENTF(R1,R2,R3,R4)=(.25*(R1+R2+R3+R4)+R1+R2)/3.
X DUF(A,B)=A-B
X MIFB2 = IFB + 2
X DO 1200 K = 2, KMAX
X DO 1000 L = 2, LMAX
X DDUAC(K,L) = SQRT(DDUF(DUAC(K+1,L),DUAC(K,L),DUAC(K-1,L),XIUKK
X 1 (L),XIUKKM(L))*XIUKKC(L))**3
X DDUBC(K,L) = SQRT(DDUF(DUBC(K,L+1),DUBC(K,L),DUBC(K,L-1),XIULL
X 1 (L),XIULL(L-1))*XIULLC(L))**3
X 1000 CONTINUE
X 1200 CONTINUE
X DO 1600 K = 1, KKMAX
X DO 1400 L = 1, LLMAX
X DDUMIN(K,L) = 0.0
X 1400 CONTINUE
X 1600 CONTINUE
X DO 2000 K = 2, KMAX
X DO 1800 L = 2, LMAX
X RKLRF = .7071067814/(TTCH(K,L)+AIF3(L))
X D2UB = (VT(K,L)-VT(K,L-1))*AKR(K,L) - (UT(K,L)-UT(K,L-1))*AKZ(
X 1 K,L)
X IF (FMEM10 - D2UB .LT. 0) D2UB = 0.0
X D4UB = (VT(K-1,L)-VT(K-1,L-1))*AKR(K,L) - (UT(K-1,L)-UT(K-1,L-
X 1 1))*AKZ(K,L)
X IF (FMEM10 - D4UB .LT. 0) D4UB = 0.0
X SQDR = 1.0/(SQRT(DKRRCH(K,L))+AIF3(L))
X Q2T(K,L) = SQRT((-D2UB*SQDR))*RKLRF*DDUBC(K,L)
X Q4T(K,L) = SQRT((-D4UB*SQDR))*RKLRF*DDUBC(K,L)
X IF (F1EM10 - Q2T(K,L) .GE. 0) Q2T(K,L) = 0.0
X IF (F1EM10 - Q4T(K,L) .GE. 0) Q4T(K,L) = 0.0
X DQE2 = -.5*DTNUP*RCENTF(RTH(K,L),RTH(K,L-1),RTH(K-1,L),RTH(K-1
X 1 ,L-1))*D2UB*Q2T(K,L)
X DQE4 = -.5*DTNUP*RCENTF(RTH(K-1,L),RTH(K-1,L-1),RTH(K,L),RTH(K
X 1 ,L-1))*D4UB*Q4T(K,L)
X D1UA = (UT(K,L)-UT(K-1,L))*ALZ(K,L) - (VT(K,L)-VT(K-1,L))*ALR(
X 1 K,L)
X IF (FMEM10 - D1UA .LT. 0) D1UA = 0.0
X D3UA = (UT(K,L-1)-UT(K-1,L-1))*ALZ(K,L) - (VT(K,L-1)-VT(K-1,L-
X 1 1))*ALR(K,L)
X IF (FMEM10 - D3UA .LT. 0) D3UA = 0.0
X DDUMIN(K,L) = -(MIN(D2UB,D4UB)+MIN(D1UA,D3UA))/(FJT(K,L)*TT(K,
X 1 L)+AIF3(L))
X SQDR = 1.0/(SQRT(DLRRCH(K,L))+AIF3(L))
X Q1T(K,L) = SQRT((-D1UA*SQDR))*RKLRF*DDUAC(K,L)
X Q3T(K,L) = SQRT((-D3UA*SQDR))*RKLRF*DDUAC(K,L)
X IF (F1EM10 - Q1T(K,L) .GE. 0) Q1T(K,L) = 0.0
X IF (F1EM10 - Q3T(K,L) .GE. 0) Q3T(K,L) = 0.0
X DQE1 = -.5*DTNUP*RCENTF(RTH(K,L),RTH(K-1,L),RTH(K,L-1),RTH(K-1
X 1 ,L-1))*D1UA*Q1T(K,L)
X DQE3 = -.5*DTNUP*RCENTF(RTH(K,L-1),RTH(K-1,L-1),RTH(K,L),RTH(K
X 1 -1,L))*D3UA*Q3T(K,L)
X DET(K,L) = DET(K,L) + (DQE1+DQE3+DQE2+DQE4)/(AMT(K,L)+AIF3(L))
X DDOR(K,L) = (DLRRCH(K,L)+DKRRCH(K,L))/((FJT(K,L)*TT(K,L))**2+
X 1 AIF3(L))
X 1800 CONTINUE
X 2000 CONTINUE
X KKQ = INDMAX(NZONM,DDUMIN(1,1),1)
X DDUMAX = DDUMIN(KKQ,1)
X IF (DDUMAX .EQ. 0) GO TO 2200
X ILQN = KKQ/KKMAX + 1
X IKQN = KKQ - (ILQN-1)*KKMAX
X DTQN = RXDTQ/(10.*DDUMAX)
X 2200 CONTINUE
X DO 2600 K = 2, KMAX
X DO 2400 L = 2, LMAX
X IF (ET(K,L) .EQ. 0) THEN
X CVMG = 1.0
X ELSE
X CVMG = ET(K,L)
X ENDIF
X DNDTC(L) = PT(K,L)*TTCH(K,L) + (PT(K,L)*TTCH(K,L))**2/CVMG
X IF (ET(K,L).LT.F1EM10 .OR. ABS(PT(K,L)).LT.F1EM10) THEN
X DNDTC(L) = 0.0
X ELSE
X DNDTC(L) = DNDTC(L)*DDOR(K,L)
X ENDIF
X 2400 CONTINUE
X 2600 CONTINUE
X RETURN
X END
X SUBROUTINE SUB035(I2,J2,K2,RTRMS)
X PARAMETER ( IGMAX=96, JGMAX=24, KGMAX=24,
X 1 IGMAX1=IGMAX+1, JGMAX1=JGMAX+1, KGMAX1=KGMAX+1,
X 2 IGMAX2=IGMAX+2, JGMAX2=JGMAX+2, KGMAX2=KGMAX+2,
X 3 IGMAX3=IGMAX+3, JGMAX3=JGMAX+3, KGMAX3=KGMAX+3,
X 4 NNMG1=(IGMAX+2)*(JGMAX+2)*(KGMAX+2),
X 5 NNMG2=(IGMAX/2+2)*(JGMAX/2+2)*(KGMAX/2+2),
X 6 NNMG3=(IGMAX/4+2)*(JGMAX/4+2)*(KGMAX/4+2),
X 7 NNMG4=(IGMAX/8+2)*(JGMAX/8+2)*(KGMAX/8+2),
X 8 NNMG5=(IGMAX/16+2)*(JGMAX/16+2)*(KGMAX/16+2),
X 8 NWD1V=NNMG1+NNMG2+NNMG3+NNMG4+NNMG5,
X 9 NWD5V=5*NWD1V,
X A NWDCRS=5*(NNMG2+NNMG3+NNMG4+NNMG5),
X B NWDFIN=5*NNMG1 )
X PARAMETER (IL=96,JL=24,KL=24)
X PARAMETER (KTIP=24,ITL=96,ITU=96)
X COMMON/DATA/ GAMMA,RM,RHO0,P0,EI0,H0,C0,U0,V0,W0,CA,SA
X COMMON/DATA/ X(IGMAX1,JGMAX1,KGMAX1,3),SCAL
X COMMON/DATA/ DTMIN,CFL,VT,HM,
X . QFIL,VIS0,VIS2,VIS4,BC,SMOOPI,SMOOPJ,SMOOPK
X COMMON/DATA/ RTMAX,HRMS,HMAX
X COMMON/DATA/ C(6)
X COMMON/DATA/ FW(IGMAX1,JGMAX1,JGMAX1,5)
X COMMON/DATA/ DW(IGMAX3,JGMAX3,KGMAX3,5)
X COMMON/DATA/ FCOLL,FADD,FBC
X COMMON/DATA/ SIX(IGMAX1),SIY(IGMAX1),SIZ(IGMAX1),
X . SJX(IGMAX1),SJY(IGMAX1),SJZ(IGMAX1),
X . SKX(IGMAX1),SKY(IGMAX1),SKZ(IGMAX1),
X . DW1(IGMAX1),DW2(IGMAX1),DW3(IGMAX1),DW4(IGMAX1),
X . DW5(IGMAX1),FS1(IGMAX1),FS2(IGMAX1),FS3(IGMAX1),
X . FS4(IGMAX1),FS5(IGMAX1),GS1(IGMAX1),GS2(IGMAX1),
X . GS3(IGMAX1),GS4(IGMAX1),GS5(IGMAX1),
X . HS1(IGMAX1,JGMAX1),HS2(IGMAX1,JGMAX1),
X . HS3(IGMAX1,JGMAX1),HS4(IGMAX1,JGMAX1),
X . HS5(IGMAX1,JGMAX1)
X COMMON/DATA/ QQQ(IGMAX+1),H(IGMAX+1),RT(IGMAX+1)
X COMMON /DATA/ WR(96,24,24,5),W1(96,24,24,5),
X . P(96,24,24),VOL(96,24,24),DTL(96,24,24)
X COMMON /DATA/W(96,24,24,5)
X DATA NSUP/0/,MSTAGE/2/
C
X MDISSP = 1
X IF (QFIL .GT. 0.) MDISSP = 2
C
X KSMOOP = 0
X IF (SMOOPI.NE.0. .OR. SMOOPJ.NE.0. .OR. SMOOPK.NE.0.) KSMOOP = 1
X IF (SMOOPI.LT.0. .OR. SMOOPJ.LT.0. .OR. SMOOPK.LT.0.) KSMOOP = -1
X ISMOOP = IABS(KSMOOP)
X IF (MOD(MSTAGE,2) .EQ. 0) ISMOOP = KSMOOP
X NSTAGE = 1
C
X DO 1400 K = 1, K2
X DO 1200 J = 1, J2
X DO 1000 I = 1, I2
X W1(I,J,K,1) = W(I,J,K,1)
X W1(I,J,K,2) = W(I,J,K,2)
X W1(I,J,K,3) = W(I,J,K,3)
X W1(I,J,K,4) = W(I,J,K,4)
X W1(I,J,K,5) = W(I,J,K,5)
X 1000 CONTINUE
X 1200 CONTINUE
X 1400 CONTINUE
X 1600 CONTINUE
C
X FN = .25*C(NSTAGE)*CFL
X FT = (1.-VT)*FN
X GT = VT*FN*DTMIN
C
X DO 2000 J = 2, JL
X M = J - 1
X DO 1800 I = 2, IL
X L = I - 1
X SX = (X(I,J,1,2)-X(L,M,1,2))*(X(L,J,1,3)-X(I,M,1,3)) - (X(I,J,
X 1 1,3)-X(L,M,1,3))*(X(L,J,1,2)-X(I,M,1,2))
X SY = (X(I,J,1,3)-X(L,M,1,3))*(X(L,J,1,1)-X(I,M,1,1)) - (X(I,J,
X 1 1,1)-X(L,M,1,1))*(X(L,J,1,3)-X(I,M,1,3))
X SZ = (X(I,J,1,1)-X(L,M,1,1))*(X(L,J,1,2)-X(I,M,1,2)) - (X(I,J,
X 1 1,2)-X(L,M,1,2))*(X(L,J,1,1)-X(I,M,1,1))
X HS1(I,J) = 0.
X HS2(I,J) = (P(I,J,2)+P(I,J,1))*SX
X HS3(I,J) = (P(I,J,2)+P(I,J,1))*SY
X HS4(I,J) = (P(I,J,2)+P(I,J,1))*SZ
X HS5(I,J) = 0.
X 1800 CONTINUE
X 2000 CONTINUE
C
X DO 3800 K = 2, KL
X N = K - 1
C
X DO 2200 I = 2, IL
X L = I - 1
X SX = (X(I,1,N,2)-X(L,1,K,2))*(X(L,1,N,3)-X(I,1,K,3)) - (X(I,1,
X 1 N,3)-X(L,1,K,3))*(X(L,1,N,2)-X(I,1,K,2))
X SY = (X(I,1,N,3)-X(L,1,K,3))*(X(L,1,N,1)-X(I,1,K,1)) - (X(I,1,
X 1 N,1)-X(L,1,K,1))*(X(L,1,N,3)-X(I,1,K,3))
X SZ = (X(I,1,N,1)-X(L,1,K,1))*(X(L,1,N,2)-X(I,1,K,2)) - (X(I,1,
X 1 N,2)-X(L,1,K,2))*(X(L,1,N,1)-X(I,1,K,1))
X RA = W(I,2,K,1) + W(I,1,K,1)
X RUA = W(I,2,K,2) + W(I,1,K,2)
X RVA = W(I,2,K,3) + W(I,1,K,3)
X RWA = W(I,2,K,4) + W(I,1,K,4)
X REA = W(I,2,K,5) + W(I,1,K,5)
X PA = P(I,2,K) + P(I,1,K)
X QS = (RUA*SX+RVA*SY+RWA*SZ)*RA
X IF (K.LE.KTIP .AND. I.GT.ITL .AND. I.LE.ITU) QS = 0.
X GS1(I) = QS*RA
X GS2(I) = QS*RUA + PA*SX
X GS3(I) = QS*RVA + PA*SY
X GS4(I) = QS*RWA + PA*SZ
X GS5(I) = QS*(REA+PA)
X 2200 CONTINUE
C
X DO 3600 J = 2, JL
C
X M = J - 1
X DO 2400 I = 1, IL
X SIX(I) = (X(I,J,N,2)-X(I,M,K,2))*(X(I,J,K,3)-X(I,M,N,3)) - (
X 1 X(I,J,N,3)-X(I,M,K,3))*(X(I,J,K,2)-X(I,M,N,2))
X SIY(I) = (X(I,J,N,3)-X(I,M,K,3))*(X(I,J,K,1)-X(I,M,N,1)) - (
X 1 X(I,J,N,1)-X(I,M,K,1))*(X(I,J,K,3)-X(I,M,N,3))
X SIZ(I) = (X(I,J,N,1)-X(I,M,K,1))*(X(I,J,K,2)-X(I,M,N,2)) - (
X 1 X(I,J,N,2)-X(I,M,K,2))*(X(I,J,K,1)-X(I,M,N,1))
X 2400 CONTINUE
X DO 2600 I = 2, IL
X L = I - 1
X SJX(I) = (X(I,J,N,2)-X(L,J,K,2))*(X(L,J,N,3)-X(I,J,K,3)) - (
X 1 X(I,J,N,3)-X(L,J,K,3))*(X(L,J,N,2)-X(I,J,K,2))
X SJY(I) = (X(I,J,N,3)-X(L,J,K,3))*(X(L,J,N,1)-X(I,J,K,1)) - (
X 1 X(I,J,N,1)-X(L,J,K,1))*(X(L,J,N,3)-X(I,J,K,3))
X SJZ(I) = (X(I,J,N,1)-X(L,J,K,1))*(X(L,J,N,2)-X(I,J,K,2)) - (
X 1 X(I,J,N,2)-X(L,J,K,2))*(X(L,J,N,1)-X(I,J,K,1))
X SKX(I) = (X(I,J,K,2)-X(L,M,K,2))*(X(L,J,K,3)-X(I,M,K,3)) - (
X 1 X(I,J,K,3)-X(L,M,K,3))*(X(L,J,K,2)-X(I,M,K,2))
X SKY(I) = (X(I,J,K,3)-X(L,M,K,3))*(X(L,J,K,1)-X(I,M,K,1)) - (
X 1 X(I,J,K,1)-X(L,M,K,1))*(X(L,J,K,3)-X(I,M,K,3))
X SKZ(I) = (X(I,J,K,1)-X(L,M,K,1))*(X(L,J,K,2)-X(I,M,K,2)) - (
X 1 X(I,J,K,2)-X(L,M,K,2))*(X(L,J,K,1)-X(I,M,K,1))
X 2600 CONTINUE
C
X RUA = W(I+1,J,K,2) + W(I,J,K,2)
X RVA = W(I+1,J,K,3) + W(I,J,K,3)
X RWA = W(I+1,J,K,4) + W(I,J,K,4)
X REA = W(I+1,J,K,5) + W(I,J,K,5)
X PA = P(I+1,J,K) + P(I,J,K)
X QS = (RUA*SIX(I)+RVA*SIY(I)+RWA*SIZ(I))*RA
X FS1(I) = QS*RA
X FS2(I) = QS*RUA + PA*SIX(I)
X FS3(I) = QS*RVA + PA*SIY(I)
X FS4(I) = QS*RWA + PA*SIZ(I)
X FS5(I) = QS*(REA+PA)
X 2800 CONTINUE
C
X DO 3000 I = 2, IL
X DW1(I) = FS1(I) - FS1(I-1) - GS1(I) - HS1(I,J)
X DW2(I) = FS2(I) - FS2(I-1) - GS2(I) - HS2(I,J)
X DW3(I) = FS3(I) - FS3(I-1) - GS3(I) - HS3(I,J)
X DW4(I) = FS4(I) - FS4(I-1) - GS4(I) - HS4(I,J)
X DW5(I) = FS5(I) - FS5(I-1) - GS5(I) - HS5(I,J)
X 3000 CONTINUE
X DO 3200 I = 2, IL
C
X RA = W(I,J+1,K,1) + W(I,J,K,1)
X RUA = W(I,J+1,K,2) + W(I,J,K,2)
X RVA = W(I,J+1,K,3) + W(I,J,K,3)
X RWA = W(I,J+1,K,4) + W(I,J,K,4)
X REA = W(I,J+1,K,5) + W(I,J,K,5)
X PA = P(I,J+1,K) + P(I,J,K)
X QS = (RUA*SJX(I)+RVA*SJY(I)+RWA*SJZ(I))*RA
X GS1(I) = QS*RA
X GS2(I) = QS*RUA + PA*SJX(I)
X GS3(I) = QS*RVA + PA*SJY(I)
X GS4(I) = QS*RWA + PA*SJZ(I)
X GS5(I) = QS*(REA+PA)
C
X RA = W(I,J,K+1,1) + W(I,J,K,1)
X RUA = W(I,J,K+1,2) + W(I,J,K,2)
X RVA = W(I,J,K+1,3) + W(I,J,K,3)
X RWA = W(I,J,K+1,4) + W(I,J,K,4)
X REA = W(I,J,K+1,5) + W(I,J,K,5)
X PA = P(I,J,K+1) + P(I,J,K)
X QS = (RUA*SKX(I)+RVA*SKY(I)+RWA*SKZ(I))*RA
X HS1(I,J) = QS*RA
X HS2(I,J) = QS*RUA + PA*SKX(I)
X HS3(I,J) = QS*RVA + PA*SKY(I)
X HS4(I,J) = QS*RWA + PA*SKZ(I)
X HS5(I,J) = QS*(REA+PA)
X 3200 CONTINUE
C
X DO 3400 I = 2, IL
X DW(I,J,K,1) = DW1(I) + GS1(I) + HS1(I,J) + FW(I,J,K,1)
X DW(I,J,K,2) = DW2(I) + GS2(I) + HS2(I,J) + FW(I,J,K,2)
X DW(I,J,K,3) = DW3(I) + GS3(I) + HS3(I,J) + FW(I,J,K,3)
X DW(I,J,K,4) = DW4(I) + GS4(I) + HS4(I,J) + FW(I,J,K,4)
X DW(I,J,K,5) = DW5(I) + GS5(I) + HS5(I,J) + FW(I,J,K,5)
X 3400 CONTINUE
X 3600 CONTINUE
X 3800 CONTINUE
X DO 4400 K = 2, KL
X DO 4200 J = 2, JL
X DO 4000 I = 2, IL
X WR(I,J,K,1) = FCOLL*WR(I,J,K,1) - DW(I,J,K,1)
X WR(I,J,K,2) = FCOLL*WR(I,J,K,2) - DW(I,J,K,2)
X WR(I,J,K,3) = FCOLL*WR(I,J,K,3) - DW(I,J,K,3)
X WR(I,J,K,4) = FCOLL*WR(I,J,K,4) - DW(I,J,K,4)
X WR(I,J,K,5) = FCOLL*WR(I,J,K,5) - DW(I,J,K,5)
X 4000 CONTINUE
X 4200 CONTINUE
X 4400 CONTINUE
X 4600 CONTINUE
X DO 5200 K = 2, KL
X DO 5000 J = 2, JL
X DO 4800 I = 2, IL
X DW(I,J,K,1) = DW(I,J,K,1) + WR(I,J,K,1)
X DW(I,J,K,2) = DW(I,J,K,2) + WR(I,J,K,2)
X DW(I,J,K,3) = DW(I,J,K,3) + WR(I,J,K,3)
X DW(I,J,K,4) = DW(I,J,K,4) + WR(I,J,K,4)
X DW(I,J,K,5) = DW(I,J,K,5) + WR(I,J,K,5)
X 4800 CONTINUE
X 5000 CONTINUE
X 5200 CONTINUE
X DO 5800 K = 2, KL
X DO 5600 J = 2, JL
X DO 5400 I = 2, IL
X DT = (FT*DTL(I,J,K)+GT)*VOL(I,J,K)
X DW(I,J,K,1) = DT*DW(I,J,K,1)
X DW(I,J,K,2) = DT*DW(I,J,K,2)
X DW(I,J,K,3) = DT*DW(I,J,K,3)
X DW(I,J,K,4) = DT*DW(I,J,K,4)
X DW(I,J,K,5) = DT*DW(I,J,K,5)
X 5400 CONTINUE
X 5600 CONTINUE
X 5800 CONTINUE
C
X DO 6400 K = 2, KL
X DO 6200 J = 2, JL
X DO 6000 I = 2, IL
X W(I,J,K,1) = W1(I,J,K,1) - DW(I,J,K,1)
X W(I,J,K,2) = W1(I,J,K,2) - DW(I,J,K,2)
X W(I,J,K,3) = W1(I,J,K,3) - DW(I,J,K,3)
X W(I,J,K,4) = W1(I,J,K,4) - DW(I,J,K,4)
X W(I,J,K,5) = W1(I,J,K,5) - DW(I,J,K,5)
X QQ = (W(I,J,K,2)+W(I,J,K,3)+W(I,J,K,4))*W(I,J,K,1)
X P(I,J,K) = (GAMMA-1.)*(W(I,J,K,5)-.5*QQ+H0*W(I,J,K,1))
X 6000 CONTINUE
X 6200 CONTINUE
X 6400 CONTINUE
X IF (NSTAGE .EQ. MSTAGE) GO TO 6600
C
X NSTAGE = NSTAGE + 1
X IF (KSMOOP .LT. 0) ISMOOP = -ISMOOP
X GO TO 1600
C
X 6600 CONTINUE
X IF (HM .LE. 0.) GO TO 7400
C
X DO 7200 K = 2, KL
X DO 7000 J = 2, JL
X DO 6800 I = 2, IL
X F = 1. + HM*(W(I,J,K,5)+P(I,J,K))*W(I,J,K,1)
X W(I,J,K,1) = F*W(I,J,K,1)
X W(I,J,K,2) = F*W(I,J,K,2)
X W(I,J,K,3) = F*W(I,J,K,3)
X W(I,J,K,4) = F*W(I,J,K,4)
X W(I,J,K,5) = (W(I,J,K,5)-HM*P(I,J,K))*(1.+HM)
X QQ = (W(I,J,K,2)+W(I,J,K,3)+W(I,J,K,4))*W(I,J,K,1)
X P(I,J,K) = (GAMMA-1.)*(W(I,J,K,5)-.5*QQ+H0*W(I,J,K,1))
X 6800 CONTINUE
X 7000 CONTINUE
X 7200 CONTINUE
X 7400 CONTINUE
C
X HRMS = 0.
X HMAX = 0.
X HMAXI = 0.
X RTRMS = 0.
X RTMAX = 0.
X RTMAXI = 0.
X NSUP = 0
X DO 9000 K = 2, KL
X DO 8800 J = 2, JL
X DO 7600 I = 2, IL
X QQQ(I) = (W(I,J,K,2)+W(I,J,K,3)+W(I,J,K,4))*W(I,J,K,1)
X H(I) = ABS((W(I,J,K,5)+P(I,J,K))*W(I,J,K,1))
X HRMS = HRMS + H(I)
X HMAXI = AMAX1(HMAXI,H(I))
X DT = ABS(CFL*((1.-VT)*DTL(I,J,K)+VT*DTMIN))
X RT(I) = (W(I,J,K,1)-W1(I,J,K,1))*DT
X RTRMS = RTRMS + RT(I)
X RTMAXI = AMAX1(RTMAXI,RT(I))
X 7600 CONTINUE
C
X IF (HMAXI .GT. HMAX) THEN
X DO 7800 I = 2, IL
X IF (HMAXI .EQ. H(I)) THEN
X IH = I
X JH = J
X KH = K
X HMAX = HMAXI
X GO TO 8000
X ENDIF
X 7800 CONTINUE
X ENDIF
C
X 8000 CONTINUE
C
X IF (RTMAXI .GT. RTMAX) THEN
X DO 8200 I = 2, IL
X IF (RTMAXI .EQ. RT(I)) THEN
X IRT = I
X JRT = J
X KRT = K
X RTMAX = RTMAXI
X GO TO 8400
X ENDIF
X 8200 CONTINUE
X ENDIF
C
X 8400 CONTINUE
C
X DO 8600 I = 2, IL
X IF (QQQ(I) .GT. GAMMA*P(I,J,K)) NSUP = NSUP + 1
X 8600 CONTINUE
C
X 8800 CONTINUE
X 9000 CONTINUE
C
C
X RTRMS = SQRT(RTRMS*FLOAT((IL-1)*(JL-1)*(KL-1)))
X HRMS = SQRT(HRMS*FLOAT((IL-1)*(JL-1)*(KL-1)))
X RETURN
X END
X SUBROUTINE SUB036(N,M,A2)
X DIMENSION A2(M,N)
C
X PARAMETER (IDIM1=100)
X PARAMETER (IDIM2=100)
X PARAMETER (IDIM3=IDIM1*IDIM2)
C
X REAL A1(IDIM1)
X REAL B1(IDIM1)
X REAL C1(IDIM1)
X REAL D1(IDIM1)
X REAL E1(IDIM1)
X REAL F1(IDIM1)
X REAL G1(IDIM1)
X REAL H1(IDIM1)
C
X COMMON /DATA/A1,B1,C1,D1,E1,F1,G1,H1
C
X REAL B2(IDIM1,IDIM2)
X REAL C2(IDIM1,IDIM2)
X REAL D2(IDIM1,IDIM2)
X REAL E2(IDIM1,IDIM2)
X REAL F2(IDIM1,IDIM2)
X REAL G2(IDIM1,IDIM2)
X REAL H2(IDIM1,IDIM2)
X INTEGER I2(IDIM1,IDIM2)
X INTEGER J2(IDIM1,IDIM2)
X INTEGER K2(IDIM1,IDIM2)
X INTEGER L2(IDIM1,IDIM2)
X INTEGER M2(IDIM1,IDIM2)
X INTEGER N2(IDIM1,IDIM2)
X REAL O2(IDIM1,IDIM2)
X REAL R2(IDIM1,IDIM2)
X REAL Z2(IDIM1,IDIM2)
X INTEGER INT2(IDIM1,IDIM2)
X LOGICAL LOG2(IDIM1,IDIM2)
X DOUBLE PRECISION DBLE2(IDIM1,IDIM2)
X DOUBLE PRECISION DBLE22(IDIM1,IDIM2)
X COMPLEX CMPLX2(IDIM1,IDIM2)
C
X COMMON /DATA/B2,C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2,N2
X COMMON /DATA/ INT2,LOG2,DBLE2,DBLE22,CMPLX2,O2,R2,Z2
X
C
C INITIALIZE VARIABLES
C
X DO 1200 I = 1, N
X DO 1000 J = 1, M
X INT2(I,J) = 1
X LOG2(I,J) = .TRUE.
X DBLE2(I,J) = 1.
X DBLE22(I,J) = 1.
X CMPLX2(I,J) = 1.
X 1000 CONTINUE
X 1200 CONTINUE
X S1 = 0
X
C
C
C DOUBLY DIMENSIONED ARRAY - SIMPLE ASSIGNMENT
C
X DO 1600 I = 1, N
X DO 1400 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X 1400 CONTINUE
X 1600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH SCALAR MULTIPLIER
C
X DO 2000 I = 1, N
X DO 1800 J = 1, M
X A2(J,I) = B2(J,I) + S1*C2(J,I)
X 1800 CONTINUE
X 2000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH ONE DIMENSIONAL MULTIPLIER
C
X DO 2400 I = 1, N
X DO 2200 J = 1, M
X A2(J,I) = B2(J,I) + D1(I)*C2(J,I)
X 2200 CONTINUE
X 2400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH ONE DIMENSIONAL MULTIPLIER
C
X DO 2800 I = 1, N
X DO 2600 J = 1, M
X A2(J,I) = E2(J,I) + F1(J)*G2(J,I)
X 2600 CONTINUE
X 2800 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY - WITH REUSED VALUE
C
X DO 3200 I = 1, N
X DO 3000 J = 1, M
X A2(J,I) = B2(J,I) + C2(J,I)
X B2(J,I) = A2(J,I) + D2(J,I)
X 3000 CONTINUE
X 3200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE SCALAR TEMPORARY
C
X DO 3600 I = 1, N
X DO 3400 J = 1, M
X A06 = B2(J,I) + C2(J,I)
X A2(J,I) = A06*D2(J,I)
X 3400 CONTINUE
X 3600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PARTITIONED ARRAY TEMPORARY
C
X DO 4000 I = 1, N
X DO 3800 J = 1, M
X A1(I) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(I)*D2(J,I)
X 3800 CONTINUE
X 4000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH PRIVATE ARRAY TEMPORARY
C
X DO 4400 I = 1, N
X DO 4200 J = 1, M
X A1(J) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(J)*D2(J,I)
X 4200 CONTINUE
X 4400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH BOTH PRIVATE AND SHARED TEMPORARIES
C
X DO 4800 I = 1, N
X DO 4600 J = 1, M
X A1(I) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(I)*D2(J,I)
X B1(J) = E2(J,I) + F2(J,I)
X B2(J,I) = B1(J)*G2(J,I)
X 4600 CONTINUE
X 4800 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH INTRINSIC FUNCTION REFERENCES
C
X DO 5200 I = 1, N
X DO 5000 J = 1, M
X A2(J,I) = SQRT(D2(J,I))
X B2(J,I) = ABS(D2(J,I))
X C2(J,I) = MOD(D2(J,I),E2(J,I))
X D2(J,I) = EXP(D2(J,I))
X E2(J,I) = ALOG(D2(J,I))
X F2(J,I) = ALOG10(D2(J,I))
X 5000 CONTINUE
X 5200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH TYPE CONVERSION INTRINSICS
C
X DO 5600 I = 1, N
X DO 5400 J = 1, M
X A2(J,I) = FLOAT(INT2(J,I))
X B2(J,I) = REAL(D2(J,I))
X C2(J,I) = SNGL(DBLE2(J,I))
X I2(J,I) = INT(D2(J,I))
X J2(J,I) = IFIX(D2(J,I))
X K2(J,I) = IDINT(DBLE2(J,I))
X R2(J,I) = DBLE(D2(J,I))
X Z2(J,I) = CMPLX(D2(J,I),B2(J,I))
X 5400 CONTINUE
X 5600 CONTINUE
C
C DOUBLY DIMENSIONED D.P. WITH INTRINSIC FUNCTION REFERENCES
C
X DO 6000 I = 1, N
X DO 5800 J = 1, M
X A2(J,I) = DSQRT(DBLE2(J,I))
X B2(J,I) = DABS(DBLE2(J,I))
X C2(J,I) = DMOD(DBLE2(J,I),DBLE22(J,I))
X D2(J,I) = DEXP(DBLE2(J,I))
X E2(J,I) = DLOG(DBLE2(J,I))
X F2(J,I) = DLOG10(DBLE2(J,I))
X 5800 CONTINUE
X 6000 CONTINUE
C
C DOUBLY DIMENSIONED D.P. WITH TRIG INTRINSIC FUNCTION
C
X DO 6400 I = 1, N
X DO 6200 J = 1, M
X A2(J,I) = DSIN(DBLE2(J,I))
X B2(J,I) = DCOS(DBLE2(J,I))
X C2(J,I) = DTAN(DBLE2(J,I))
X D2(J,I) = DASIN(DBLE2(J,I))
X E2(J,I) = DACOS(DBLE2(J,I))
X F2(J,I) = DATAN(DBLE2(J,I))
X G2(J,I) = DATAN2(DBLE2(J,I),DBLE22(J,I))
X 6200 CONTINUE
X 6400 CONTINUE
C
C DOUBLY DIMENSIONED D.P. WITH HYPERBOLIC TRIG FUNCTIONS
C
X DO 6800 I = 1, N
X DO 6600 J = 1, M
X A2(J,I) = DSINH(DBLE2(J,I))
X B2(J,I) = DCOSH(DBLE2(J,I))
X C2(J,I) = DTANH(DBLE2(J,I))
X 6600 CONTINUE
X 6800 CONTINUE
C
C DOUBLY DIMENSIONED D.P. WITH LESSER USED INTRINSICS
C
X DO 7200 I = 1, N
X DO 7000 J = 1, M
X A2(J,I) = DINT(DBLE2(J,I))
X B2(J,I) = DNINT(DBLE2(J,I))
X C2(J,I) = DSIGN(DBLE2(J,I),DBLE22(J,I))
X D2(J,I) = DDIM(DBLE2(J,I),DBLE22(J,I))
X 7000 CONTINUE
X 7200 CONTINUE
C
C DOUBLY DIMENSIONED COMPLEX INTRINSICS
C
X DO 7600 I = 1, N
X DO 7400 J = 1, M
X A2(J,I) = CABS(CMPLX2(J,I))
X B2(J,I) = CSIN(CMPLX2(J,I))
X B2(J,I) = CCOS(CMPLX2(J,I))
X B2(J,I) = CSQRT(CMPLX2(J,I))
X B2(J,I) = CEXP(CMPLX2(J,I))
X B2(J,I) = CLOG(CMPLX2(J,I))
X 7400 CONTINUE
X 7600 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH IF..THEN CONDITION
C
X DO 8000 I = 1, N
X DO 7800 J = 1, M
X IF (B2(J,I) .NE. 0.0) A2(J,I) = C2(J,I)
X 7800 CONTINUE
X 8000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH IF..THEN...ELSE CONDITION
C
X DO 8400 I = 1, N
X DO 8200 J = 1, M
X IF (B2(J,I) .NE. 0.0) THEN
X A2(J,I) = C2(J,I)
X ELSE
X B2(J,I) = C2(J,I)
X ENDIF
X 8200 CONTINUE
X 8400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH IF..GOTO CONDITION
C
X DO 9200 I = 1, N
X DO 9000 J = 1, M
X IF (B2(J,I) .EQ. 0.0) GO TO 8600
X A2(J,I) = C2(J,I)
X GO TO 8800
X 8600 CONTINUE
X B2(J,I) = C2(J,I)
X 8800 CONTINUE
X 9000 CONTINUE
X 9200 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH THREE BRANCH IF
C
X DO 10000 I = 1, N
X DO 9800 J = 1, M
X A2(J,I) = C2(J,I)
X IF (B2(J,I) .GE. 0) GO TO 9400
X B2(J,I) = C2(J,I)
X GO TO 9600
X 9400 CONTINUE
X C2(J,I) = C2(J,I)
X 9600 CONTINUE
X 9800 CONTINUE
X10000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH INDIRECT LOGICAL IF
C
X DO 11000 I = 1, N
X DO 10800 J = 1, M
X A2(J,I) = C2(J,I)
X IF (B2(J,I) .EQ. 0.0) GO TO 10400
X10200 CONTINUE
X B2(J,I) = C2(J,I)
X GO TO 10600
X10400 CONTINUE
X C2(J,I) = C2(J,I)
X10600 CONTINUE
X10800 CONTINUE
X11000 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH COMPOUND BLOCK IF
C
X DO 11400 I = 1, N
X DO 11200 J = 1, M
X IF (B2(J,I) .EQ. 0.0) THEN
X A2(J,I) = C2(J,I)
X ELSE IF (B2(J,I) .GT. 0.0) THEN
X B2(J,I) = C2(J,I)
X ELSE IF (C2(J,I) .GT. 0.0) THEN
X C2(J,I) = C2(J,I)
X ELSE
X D2(J,I) = C2(J,I)
X ENDIF
X11200 CONTINUE
X11400 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH NESTED BLOCK IF
C
X DO 11800 I = 1, N
X DO 11600 J = 1, M
X IF (B2(J,I) .EQ. 0.0) THEN
X A2(J,I) = C2(J,I)
X IF (D2(J,I) .GT. 0.0) THEN
X B2(J,I) = C2(J,I)
X ELSE
X C2(J,I) = C2(J,I)
X ENDIF
X ELSE
X D2(J,I) = C2(J,I)
X ENDIF
X11600 CONTINUE
X11800 CONTINUE
C
C DOUBLY DIMENSIONED ARRAY WITH COMPUTED GOTO
C
X DO 13000 I = 1, N
X DO 12800 J = 1, M
X GO TO (12000,12200,12400,12600) INT2(I,J)
X A2(J,I) = A2(J,I)
X12000 CONTINUE
X B2(J,I) = B2(J,I)
X12200 CONTINUE
X C2(J,I) = C2(J,I)
X12400 CONTINUE
X D2(J,I) = D2(J,I)
X12600 CONTINUE
X E2(J,I) = D2(J,I)
X12800 CONTINUE
X13000 CONTINUE
C
C COMPUTED GOTO RECAST AS BLOCK IFS
C
X DO 13400 I = 1, N
X DO 13200 J = 1, M
X IF (INT2(I,J).LE.0 .OR. INT2(I,J).GT.4) A2(J,I) = A2(J,I)
X IF (INT2(I,J).LE.1 .OR. INT2(I,J).GT.4) B2(J,I) = A2(J,I)
X IF (INT2(I,J).LE.2 .OR. INT2(I,J).GT.4) C2(J,I) = A2(J,I)
X IF (INT2(I,J).LE.3 .OR. INT2(I,J).GT.4) D2(J,I) = A2(J,I)
X E2(J,I) = A2(J,I)
X13200 CONTINUE
X13400 CONTINUE
C
C ASSIGNED GOTO (PRIVATE DECLARATION NEEDED)
C
X DO 14400 I = 1, N
X DO 14200 J = 1, M
X ASSIGN 13600 TO ILBL
X A2(J,I) = A2(J,I)
X IF (C2(J,I) .NE. 0.0) THEN
X ASSIGN 13800 TO ILBL
X B2(J,I) = B2(J,I)
X ENDIF
X GO TO ILBL
X13600 CONTINUE
X C2(J,I) = C2(J,I)
X GO TO 14000
X13800 CONTINUE
X D2(J,I) = D2(J,I)
X14000 CONTINUE
X14200 CONTINUE
X14400 CONTINUE
C
C DOUBLE LOOP INVOLVING PRIVATE ARRAY PASSED FROM FIRST TO SECOND
C
X DO 15000 I = 1, N
X DO 14600 J = 1, M
X A1(J) = D2(J,I) + A2(J,I)
X14600 CONTINUE
X DO 14800 J = 2, M - 1
X B2(J,I) = A1(J)*B2(J,I)
X14800 CONTINUE
X15000 CONTINUE
C
C DOUBLE LOOP WITH INNER DEPENDENT LOOP
C
X DO 15400 I = 1, N
X DO 15200 J = 2, M
X A2(J,I) = A2(J,I) - A2(J-1,I)*.99999
X15200 CONTINUE
X15400 CONTINUE
C
C DOUBLE LOOP INVOLVING PRIVATE ARRAY WITH DEPENDENCY
C
X DO 16000 I = 1, N
X A1(1) = 1.0
X DO 15600 J = 2, M
X A1(J) = C2(J,I) - A1(J-1)*B2(J,I)
X15600 CONTINUE
X DO 15800 J = 1, M
X B2(J,I) = D2(J,I)*A1(J)
X15800 CONTINUE
X16000 CONTINUE
C
C DOUBLE LOOP WITH SEPARABLE DEPENDENCY ON FIRST ITERATION
C
X DO 16600 I = 1, N
X IF (I .EQ. 1) THEN
X DO 16200 J = 1, M
X A2(J,I) = A2(J,I) + A2(J,N)/2.0
X16200 CONTINUE
X ELSE
X DO 16400 J = 1, M
X A2(J,I) = D2(J,I)*A2(J,I)
X16400 CONTINUE
X ENDIF
X16600 CONTINUE
C
C DOUBLE LOOP WITH UNROLLING
C
X DO 17000 I = 1, N, 4
X DO 16800 J = 1, M
X A2(J,I) = A2(J,I) + D2(J,I)
X A2(J,I+1) = A2(J,I+1) + D2(J,I+1)
X A2(J,I+2) = A2(J,I+2) + D2(J,I+2)
X A2(J,I+3) = A2(J,I+3) + D2(J,I+3)
X16800 CONTINUE
X17000 CONTINUE
C
C DOUBLE LOOP WITH DEPENDENCY EQUAL TO STRIDE ON OUTER LOOP
C
X DO 17400 I = 1, N, 2
X DO 17200 J = 1, M
X A2(J,I) = A2(J,I) + D2(J,I)
X A2(J,I+1) = A2(J,I+1) + A2(J,I)*C2(J,I)
X17200 CONTINUE
X17400 CONTINUE
C
C TRIANGULAR MATRIX OPERATION
C
X DO 17800 I = 1, N
X DO 17600 J = 1, I
X A2(I,J) = A2(J,I)*D2(J,I)
X17600 CONTINUE
X17800 CONTINUE
C
C NON-OVERLAPPING REFERENCES TO THE SAME ARRAY
C
X NM2 = N/2
X DO 18200 I = 1, NM2
X DO 18000 J = 1, M
X A2(J,I) = A2(J,I)*A2(J,I+NM2)
X18000 CONTINUE
X18200 CONTINUE
C
X RETURN
X END
X integer function isamax(n,sx,incx)
c
c finds the index of element having max. absolute value.
c jack dongarra, linpack, 3/11/78.
c modified to correct problem with negative increments, 9/29/88.
c
X real sx(1),smax
X integer i,incx,ix,n
c
X isamax = 0
X if( n .lt. 1 ) return
X isamax = 1
X if(n.eq.1)return
X if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
X ix = 1
X if(incx.lt.0)ix = (-n+1)*incx + 1
X smax = abs(sx(ix))
X ix = ix + incx
X do 10 i = 2,n
X if(abs(sx(ix)).le.smax) go to 5
X isamax = i
X smax = abs(sx(ix))
X 5 ix = ix + incx
X 10 continue
X return
c
c code for increment equal to 1
c
X 20 smax = abs(sx(1))
X do 30 i = 2,n
X if(abs(sx(i)).le.smax) go to 30
X isamax = i
X smax = abs(sx(i))
X 30 continue
X return
X end
END_OF_FILE
if test 202081 -ne `wc -c <'subs.f'`; then
echo shar: \"'subs.f'\" unpacked with wrong size!
fi
# end of 'subs.f'
fi
if test -f 'loops2.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'loops2.f'\"
else
echo shar: Extracting \"'loops2.f'\" \(42103 characters\)
sed "s/^X//" >'loops2.f' <<'END_OF_FILE'
X PROGRAM TEST
X
C THIS PROGRAM CONSISTS OF 64 NESTED DO LOOPS. THEY ARE TIMED FOR
C WALL CLOCK TIME. THE MFLOPS ARE CALCULATED BY DIVIDING THE
C THE TOTAL NUMBER OF FLOATING POINT OPERATIONS BY THE WALLCLOCK TIME.
C SEVERAL VARIABLES HAVE BEEN EQUIVALENCED TO REDUCE MEMORY USAGE.
C RTC() RETURNS THE REAL-TIME CLOCK READING, ALLOWING US TO GET
C ACCURATE WALLCLOCK TIMES.
X
X PARAMETER (NCOMBS=9)
X PARAMETER (NDIM1=1000,NDIM2=100,NDIM3=10)
X PARAMETER (NSZ1=10,NSZ2=25,NSZ3=50)
X PARAMETER (NSZ4=100,NSZ5=250,NSZ6=500,NSZ7=750)
X DIMENSION SUBSCR(NCOMBS,3)
X INTEGER SUBSCR
X DATA (SUBSCR(1,I),I=1,3)/NSZ1,NSZ1,NDIM3/
X DATA (SUBSCR(2,I),I=1,3)/NSZ2,NSZ1,NDIM3/
X DATA (SUBSCR(3,I),I=1,3)/NSZ3,NSZ1,NDIM3/
X DATA (SUBSCR(4,I),I=1,3)/NSZ4,NSZ1,NDIM3/
X DATA (SUBSCR(5,I),I=1,3)/NSZ4,NDIM2,NDIM3/
X DATA (SUBSCR(6,I),I=1,3)/NSZ5,NDIM2,NDIM3/
X DATA (SUBSCR(7,I),I=1,3)/NSZ6,NDIM2,NDIM3/
X DATA (SUBSCR(8,I),I=1,3)/NSZ7,NDIM2,NDIM3/
X DATA (SUBSCR(9,I),I=1,3)/NDIM1,NDIM2,NDIM3/
X
X DO 200 I = 1,NCOMBS
X CALL CLOOPS(I,SUBSCR(I,1),SUBSCR(I,2),SUBSCR(I,3))
X 200 CONTINUE
X
X STOP
X END
X
X
X SUBROUTINE CLOOPS(NCASE,NSIZE1,NSIZE2,NSIZE3)
X
X PARAMETER (CLOCK=6.0E-9)
X PARAMETER (NDIM1=1000,NDIM2=100,NDIM3=10)
X PARAMETER (NDIM4=32*NDIM1)
X PARAMETER (NDIM5=(NDIM1*NDIM2*NDIM3)+(NDIM1*NDIM2)+NDIM1)
X PARAMETER (NDIM6=2500)
X PARAMETER (NT1=4*NDIM1*NDIM2*NDIM3)
X PARAMETER (NT2=27*NDIM1*NDIM2)
X PARAMETER (NT3=(29*NDIM1)+(9*NDIM2)+(2*NDIM2*NDIM2))
X PARAMETER (NTOT=NT1+NT2+NT3+NDIM6)
X
X COMMON /WORK/ A2(NDIM1,NDIM2),B2(NDIM1,NDIM2),C2(NDIM1,NDIM2),
X + D2(NDIM1,NDIM2),E2(NDIM1,NDIM2),F2(NDIM1,NDIM2),
X + G2(NDIM1,NDIM2),DBLE22(NDIM1,NDIM2),
X + CMPLX2(NDIM1,NDIM2),
X + AR(NDIM1,NDIM2),AI(NDIM1,NDIM2),P2(3,NDIM1),
X + G3(NDIM1,NDIM2,NDIM3),WR2(NDIM1,NDIM2),
X + WR1(NDIM1,NDIM2),
X + DR(3,NDIM2,NDIM1),GTEN(NDIM2,NDIM2),
X + DBLE2(NDIM1,NDIM2),
X + FTEMP(NDIM1,3),H3(NDIM1,NDIM2,NDIM3)
X
X COMMON /WORK/ Q6(NDIM1,NDIM2),
X + B3(NDIM1,NDIM2,NDIM3),A3(NDIM1,NDIM2,NDIM3),
X + A1(NDIM1),B1(NDIM1),F1(NDIM1),D1(NDIM1),
X + INT2(NDIM1,NDIM2),I2(NDIM1,NDIM2),
X + J2(NDIM1,NDIM2),K2(NDIM1,NDIM2),
X + MB(NDIM2,NDIM2),C(NDIM1),ZERO(NDIM2),
X + C11(NDIM6),JSAVE(NDIM1),GG(NDIM1,14),FZT(NDIM2,1),
X + Q2(NDIM1,NDIM2),V(NDIM1,NDIM2),T2(NDIM2),
X + UQ(NDIM2),DUQ(NDIM2),TQ(NDIM2),DTQ(NDIM2),AM(NDIM1),
X + DSQ(NDIM1),SQ(NDIM1),FPP(NDIM2),FTP(NDIM2)
X
X DIMENSION F3(NDIM1,NDIM2,1)
X DIMENSION E3(NDIM1,NDIM2,10)
X DIMENSION F(NDIM1,5,NDIM2),E(NDIM1,NDIM2,5)
X DIMENSION E11(NDIM4),F11(NDIM4),D11(NDIM4)
X DIMENSION G11(NDIM4),H11(NDIM4),P11(NDIM4)
X DIMENSION A11(NDIM5),B11(NDIM5)
X DIMENSION D3(NDIM1,NDIM2,NDIM3),C3(NDIM1,NDIM2,NDIM3)
X DIMENSION X2(NDIM1,NDIM1),Y2(NDIM1,NDIM1),Z2(NDIM1,NDIM1)
X DIMENSION CMPLX3(NDIM1,NDIM2),CMPLX4(NDIM1,NDIM2)
X DIMENSION DUMMY1(NTOT)
X
X EQUIVALENCE (DUMMY1(1),A2(1,1))
X EQUIVALENCE (D3(1,1,1),A2(1,1)),(C3(1,1,1),AI(1,1))
X EQUIVALENCE (A11(1),D3(1,1,1)),(B11(1),P2(1,1))
X EQUIVALENCE (E11(1),A2(1,1)),(F11(1),B2(1,1))
X EQUIVALENCE (D11(1),C2(1,1)),(G11(1),D2(1,1))
X EQUIVALENCE (H11(1),E2(1,1)),(P11(1),F2(1,1))
X EQUIVALENCE (F(1,1,1),D3(1,1,1)),(E(1,1,1),B3(1,1,1))
X EQUIVALENCE (A2(1,1),F3(1,1,1))
X EQUIVALENCE (A2(1,1),E3(1,1,1))
X EQUIVALENCE (X2(1,1),A2(1,1)),(Y2(1,1),G3(1,1,1))
X EQUIVALENCE (CMPLX3(1,1),G3(1,1,1))
X EQUIVALENCE (CMPLX4(1,1),H3(1,1,1))
X EQUIVALENCE (Z2(1,1),H3(1,1,1))
X
X COMMON /BLK2/ TCT,TWT,TFLOPS
X
X
X INTEGER TSTART, TLOOPS(100), FLOOPS(100)
X REAL MFLOPS
X DOUBLE PRECISION DBLE2,DBLE22
X COMPLEX CMPLX2,CMPLX3,CMPLX4,CMP1(NDIM1),CMP2
X
X
X PI = 3.141592653589793
X PRINT 10, NCASE,NSIZE1,NSIZE2,NSIZE3
X DO 500 I = 1,NTOT
X DUMMY1(I) = 0
X 500 CONTINUE
X
X DO 520 I = 1,NSIZE1
X JSAVE(I) = 100
X 520 CONTINUE
X
X M1 = 1
X DO 580 I = 1,NSIZE1
X DO 560 J = 1,NSIZE2
X INT2(I,J) = M1
X M1 = M1+1
X IF (M1 .EQ. 5) M1 = 1
X 560 CONTINUE
X 580 CONTINUE
X
X TCT = 0
X TWT = 0
X TFLOPS = 0
X NLOOPS = 1
X
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1000 I = 1,NSIZE2
X DO 950 J = 1,NSIZE1
X A2(J,I) = A2(J,I) + 1
X IF (A2(J,I) .EQ. 0) GO TO 1000
X 950 CONTINUE
X 1000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1100 I = 1,NSIZE1
X DO 1030 J = 1,NSIZE1
X X2(I,J) = 0.0
X 1030 CONTINUE
X DO 1070 K = 1,NSIZE1
X DO 1050 J = 1,NSIZE1
X X2(I,J) = X2(I,J)+Y2(I,K)*Z2(K,J)
X 1050 CONTINUE
X 1070 CONTINUE
X 1100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (NSIZE1*NSIZE1*NSIZE1*2)
X NLOOPS = NLOOPS+1
X
X
X DO 1140 I = 1,NSIZE2
X DO 1120 J = 1,NSIZE1
X C2(J,I) = 0.2
X D2(J,I) = 0.1
X B2(J,I) = 0.01
X 1120 CONTINUE
X 1140 CONTINUE
X S = .0001
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1200 I = 1,NSIZE2
X DO 1150 J = 1,NSIZE1
X A2(J,I) = S
X B2(J,I) = (C2(J,I)+D2(J,I))*S
X S = B2(J,I) + C2(J,I)
X 1150 CONTINUE
X 1200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 3*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1300 J = 1,NSIZE1
X DO 1250 I = 1,NSIZE1
X X2(I,J) = Y2(I,J)
X Y2(I,J) = X2(I,J)*Z2(I,J)
X 1250 CONTINUE
X 1300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1400 J = 2,NSIZE2
X DO 1380 K = 1,NSIZE3
X DO 1360 I = 1, NSIZE1
X D3(I,J,K) = (A3(I,J-1,K)+C3(I,J,K))*AI(J,K) +
X 1 (H3(I,J-1,K)+G3(I,J,K))*WR2(J,K)
X B3(I,J,K) = V(I,J)*V(J,K) - A3(I,J,K)*V(I,J) -
X 1 H3(I,J,K)*V(I,J)
X 1340 CONTINUE
X 1360 CONTINUE
X D3(I,NSIZE2,K)=(A3(I,NSIZE2,K)+C3(I,NSIZE2,K))*
X 1 AI(NSIZE2,K)+(H3(I,NSIZE2,K)+G3(I,NSIZE2,K))*
X 2 WR2(NSIZE2,K)
X 1380 CONTINUE
X 1400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = ((NSIZE2-1)*NSIZE3*NSIZE1*10)+
X 1 ((NSIZE2-1)*5*NSIZE3)
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1500 J = 2,NSIZE2
X DO 1450 I = 2,NSIZE1
X A2(I,J) = .5*((E(I,J,1)-E(I-1,J-1,1))*(E(I-1,J,2)-E(I,J-1,2))-
X 1 (E(I,J,2)-E(I-1,J-1,2))*(E(I-1,J,1)-E(I,J-1,1)))
X 1450 CONTINUE
X A2(1,J) = A2(NSIZE1,J)
X A2(NSIZE1,J) = A2(2,J)
X 1500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (NSIZE1-1)*(NSIZE2-1)*8
X NLOOPS = NLOOPS+1
X
X JMAX = NSIZE2-2
X IMAX = NSIZE1-2
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1600 L = 1,JMAX + 1
X DO 1550 K = 1,IMAX + 1
X I = K
X J = L
X A2(I,L) = B2(I,J+1) - B2(I,J)
X C2(I,L) = D2(I,J+1) - D2(I,J)
X E2(K,J) = B2(I+1,J) - B2(I,J)
X F2(K,J) = D2(I+1,J) - D2(I,J)
X 1550 CONTINUE
X 1600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (JMAX+1)*(IMAX+1)*4
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1700 I = 1,NSIZE2
X DO 1440 J = 1,NSIZE1
X A2(J,I) = B2(J,I) + C2(J,I)
X 1440 CONTINUE
X 1700 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X S1 = 2.5
X DO 1800 I = 1,NSIZE2
X DO 1750 J = 1,NSIZE1
X A2(J,I) = B2(J,I) + S1*C2(J,I)
X 1750 CONTINUE
X 1800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 1900 I = 1,NSIZE2
X DO 1850 J = 1,NSIZE1
X A2(J,I) = B2(J,I) + D1(I)*C2(J,I)
X 1850 CONTINUE
X 1900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2000 I = 1,NSIZE2
X DO 1950 J = 1,NSIZE1
X A2(J,I) = B2(J,I) + C2(J,I)
X B2(J,I) = A2(J,I) + D2(J,I)
X 1950 CONTINUE
X 2000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2100 I = 1,NSIZE2
X DO 2050 J = 1,NSIZE1
X A06 = B2(J,I) + C2(J,I)
X A2(J,I) = A06*D2(J,I)
X 2050 CONTINUE
X 2100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2200 I = 1,NSIZE2
X DO 2150 J = 1,NSIZE1
X A1(I) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(I)*D2(J,I)
X 2150 CONTINUE
X 2200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2300 I = 1,NSIZE2
X DO 2250 J = 1,NSIZE1
X A1(I) = B2(J,I) + C2(J,I)
X A2(J,I) = A1(I)*D2(J,I)
X B1(J) = E2(J,I) + F2(J,I)
X B2(J,I) = B1(J)*G2(J,I)
X 2250 CONTINUE
X 2300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X DO 2320 I = 1,NSIZE2
X DO 2310 J = 1,NSIZE1
X E2(J,I) = 1.0
X D2(J,I) = PI
X 2310 CONTINUE
X 2320 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2400 I = 1,NSIZE2
X DO 2350 J = 1,NSIZE1
X A2(J,I) = SQRT(D2(J,I))
X B2(J,I) = ABS(D2(J,I))
X C2(J,I) = MOD(D2(J,I),E2(J,I))
X G2(J,I) = EXP(D2(J,I))
X E2(J,I) = ALOG(D2(J,I))
X F2(J,I) = ALOG10(D2(J,I))
X 2350 CONTINUE
X 2400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 113*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2500 I = 1,NSIZE2
X DO 2450 J = 1,NSIZE1
X A2(J,I) = FLOAT(INT2(J,I))
X B2(J,I) = REAL(D2(J,I))
X C2(J,I) = SNGL(DBLE2(J,I))
X I2(J,I) = INT(D2(J,I))
X J2(J,I) = IFIX(D2(J,I))
X K2(J,I) = IDINT(DBLE2(J,I))
X E2(J,I) = DBLE(D2(J,I))
X F2(J,I) = CMPLX(D2(J,I),B2(J,I))
X 2450 CONTINUE
X 2500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 3*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2600 I = 2, NSIZE1
X DO 2550 J = 2, NSIZE2
X A2(I,J) = B2(I,J) + C2(I,J) + D2(I,J) + E2(I,J) - F2(I,J)
X 2550 CONTINUE
X 2600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2700 J = 1,NSIZE2
X DO 2650 I = 1,NSIZE1
X A2(I,J) = B2(I,J) + PI*(C2(I,J)-2.*B2(I,J)+A2(I,J))
X D2(I,J) = E2(I,J) + PI*(F2(I,J)-2.*E2(I,J)+D2(I,J))
X AR(I,J) = G2(I,J) + PI*(AI(I,J)-2.*G2(I,J)+AR(I,J))
X B2(I,J) = C2(I,J)
X E2(I,J) = F2(I,J)
X G2(I,J) = AI(I,J)
X 2650 CONTINUE
X 2700 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 15*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2800 K = 2,NSIZE2
X DO 2750 I = 1,NSIZE1-1
X C2(I,K) = A2(I+1,K-1) + A2(I+1,K) - B2(I,K-1) - B2(I,K)
X D2(I,K) = A2(I,K-1) + A2(I,K) - B2(I+1,K-1) - B2(I+1,K)
X AI(I,K) = (C2(I,K)-D2(I,K))*PI*F1(K)
X G2(I,K) = (C2(I,K)+D2(I,K))*PI*F1(K)
X AI(I,K) = AI(I,K-1) + AI(I,K)
X G2(I,K) = G2(I,K-1) + G2(I,K)
X 2750 CONTINUE
X 2800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 14*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X
X DO 2820 I = 1,NSIZE2
X DO 2810 J = 1,NSIZE1
X CMPLX2(J,I) = (0.1,0.)
X 2810 CONTINUE
X 2820 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 2900 I = 1,NSIZE2
X DO 2850 J = 1,NSIZE1
X A2(J,I) = CABS(CMPLX2(J,I))
X B2(J,I) = CSIN(CMPLX2(J,I))
X B2(J,I) = CCOS(CMPLX2(J,I))
X B2(J,I) = CSQRT(CMPLX2(J,I))
X B2(J,I) = CEXP(CMPLX2(J,I))
X B2(J,I) = CLOG(CMPLX2(J,I))
X 2850 CONTINUE
X 2900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
C "133" FROM HARDWARE PERFORMANCE MONITOR FOR THIS SPECIFIC DATA CASE
X FLOOPS(NLOOPS) = 133*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X DO 2920 I = 1,NSIZE2
X DO 2910 J = 1,NSIZE1
X B2(J,I) = PI
X 2910 CONTINUE
X 2920 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3000 I = 1,NSIZE2
X DO 2950 J = 1,NSIZE1
X IF (B2(J,I) .NE. 0.0) A2(J,I) = C2(J,I)*D2(J,I)
X 2950 CONTINUE
X 3000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3100 I = 1,NSIZE2
X DO 3050 J = 1,NSIZE1
X IF (B2(J,I) .NE. 0.0) THEN
X A2(J,I) = C2(J,I)*B2(J,I)
X ELSE
X B2(J,I) = C2(J,I)*A2(J,I)
X ENDIF
X 3050 CONTINUE
X 3100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3200 I = 1,NSIZE2
X DO 3170 J = 1,NSIZE1
X IF (B2(J,I) .EQ. 0.0) GO TO 3130
X A2(J,I) = C2(J,I)*B2(J,I)
X GO TO 3170
X 3130 CONTINUE
X B2(J,I) = C2(J,I)*A2(J,I)
X 3170 CONTINUE
X 3200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3300 I = 1,NSIZE2
X DO 3270 J = 1,NSIZE1
X A2(J,I) = C2(J,I)
X IF (B2(J,I) .GE. 0) GO TO 3230
X B2(J,I) = C2(J,I)*A2(J,I)
X GO TO 3270
X 3230 CONTINUE
X C2(J,I) = C2(J,I)*A2(J,I)
X 3270 CONTINUE
X 3300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3400 K = 1,NSIZE2
X DO 3330 I = 1,NSIZE1
X CMPLX2(I,K) = 0.0
X 3330 CONTINUE
X DO 3370 J = 1,NSIZE2
X DO 3350 I = 1,NSIZE1
X CMPLX2(I,K) = CMPLX2(I,K)+CMPLX3(I,J)*CMPLX4(J,K)
X 3350 CONTINUE
X 3370 CONTINUE
X 3400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (NSIZE1*NSIZE2*NSIZE2*(2+6))
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3500 I = 1,NSIZE2
X DO 3450 J = 1,NSIZE1
X IF (B2(J,I) .EQ. 0.0) THEN
X A2(J,I) = C2(J,I) + A2(J,I)
X ELSE IF (B2(J,I) .GT. 0.0) THEN
X B2(J,I) = C2(J,I) + B2(J,I)
X ELSE IF (C2(J,I) .GT. 0.0) THEN
X C2(J,I) = C2(J,I)*A2(J,I)
X ELSE
X D2(J,I) = C2(J,I)*A2(J,I)
X ENDIF
X 3450 CONTINUE
X 3500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3600 I = 1,NSIZE2
X DO 3550 J = 1,NSIZE1
X IF (B2(J,I) .EQ. 0.0) THEN
X A2(J,I) = C2(J,I) + A2(J,I)
X IF (D2(J,I) .GT. 0.0) THEN
X B2(J,I) = C2(J,I)*A2(J,I)
X ELSE
X C2(J,I) = C2(J,I) + A2(J,I)
X ENDIF
X ELSE
X D2(J,I) = C2(J,I)*A2(J,I)
X ENDIF
X 3550 CONTINUE
X 3600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3700 I = 1,NSIZE2
X DO 3680 J = 1,NSIZE1
X GO TO (3630,3640,3650,3660) INT2(J,I)
X A2(J,I) = A2(J,I) + B2(J,I)
X 3630 CONTINUE
X B2(J,I) = B2(J,I) + C2(J,I)
X 3640 CONTINUE
X C2(J,I) = C2(J,I) + D2(J,I)
X 3650 CONTINUE
X D2(J,I) = D2(J,I) + A2(J,I)
X 3660 CONTINUE
X E2(J,I) = D2(J,I) + B2(J,I)
X 3680 CONTINUE
X 3700 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2*2.5
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3800 I = 1,NSIZE2
X DO 3750 J = 1,NSIZE1
X ITEST = INT2(J,I)
X IF (ITEST.LE.0 .OR. ITEST.GT.4) A2(J,I) = A2(J,I)*B2(J,I)
X IF (ITEST.LE.1 .OR. ITEST.GT.4) B2(J,I) = A2(J,I)*C2(J,I)
X IF (ITEST.LE.2 .OR. ITEST.GT.4) C2(J,I) = A2(J,I) + B2(J,I)
X IF (ITEST.LE.3 .OR. ITEST.GT.4) D2(J,I) = A2(J,I) + C2(J,I)
X E2(J,I) = A2(J,I)*PI + C2(J,I)*PI
X 3750 CONTINUE
X 3800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2*4.5
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 3900 I = 1,NSIZE2
X DO 3880 J = 1,NSIZE1
X ASSIGN 3820 TO ILBL
X A2(J,I) = A2(J,I)*B2(J,I)
X IF (C2(J,I) .NE. 0.0) THEN
X ASSIGN 3850 TO ILBL
X B2(J,I) = B2(J,I)*C2(J,I)
X ENDIF
X GO TO ILBL
X 3820 CONTINUE
X C2(J,I) = C2(J,I)*D2(J,I)
X GO TO 3880
X 3850 CONTINUE
X D2(J,I) = D2(J,I)*E2(J,I)
X 3880 CONTINUE
X 3900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2.5*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4000 I = 1,NSIZE2
X DO 3930 J = 1,NSIZE1
X A1(J) = D2(J,I) + A2(J,I)
X 3930 CONTINUE
X DO 3970 J = 2,NSIZE1-1
X B2(J,I) = A1(J)*B2(J,I)
X 3970 CONTINUE
X 4000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE1*NSIZE2 + (NSIZE1-2)*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4100 I = 1,NSIZE2
X DO 4050 J = 2,NSIZE1
X A2(J,I) = A2(J,I) - A2(J-1,I)*.99999
X 4050 CONTINUE
X 4100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE2*(NSIZE1-1)*2
X NLOOPS = NLOOPS+1
X
X DO 4120 I = 1,NSIZE2
X DO 4110 J = 1,NSIZE1
X C2(J,I) = 0
X B2(J,I) = 0
X D2(J,I) = 0
X 4110 CONTINUE
X 4120 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4200 I = 1,NSIZE2
X A1(1) = 1.0
X DO 4140 J = 2, NSIZE1
X A1(J) = C2(J,I) - A1(J-1)*B2(J,I)
X 4140 CONTINUE
X DO 4170 J = 1,NSIZE1
X B2(J,I) = D2(J,I)*A1(J)
X 4170 CONTINUE
X 4200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NSIZE2*(NSIZE1-1)*2 + NSIZE1
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4300 I = 1,NSIZE2
X IF (I .EQ. 1) THEN
X DO 4230 J = 1,NSIZE1
X A2(J,I) = A2(J,I) + A2(J,NSIZE2)/2.0
X 4230 CONTINUE
X ELSE
X DO 4270 J = 1,NSIZE1
X A2(J,I) = D2(J,I)*A2(J,I)
X 4270 CONTINUE
X ENDIF
X 4300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (NSIZE2-1)*NSIZE1 + NSIZE1*2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4400 I = 1,NSIZE2, 4
X DO 4350 J = 1,NSIZE1
X A2(J,I) = A2(J,I) + D2(J,I)
X A2(J,I+1) = A2(J,I+1) + D2(J,I+1)
X A2(J,I+2) = A2(J,I+2) + D2(J,I+2)
X A2(J,I+3) = A2(J,I+3) + D2(J,I+3)
X 4350 CONTINUE
X 4400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*(NSIZE2/4)*NSIZE1
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4500 I = 1,NSIZE2,2
X DO 4450 J = 1,NSIZE1
X A2(J,I) = A2(J,I) + D2(J,I)
X A2(J,I+1) = A2(J,I+1) + A2(J,I)*C2(J,I)
X 4450 CONTINUE
X 4500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = ((NSIZE2+1)/2)*NSIZE1*3
X NLOOPS = NLOOPS+1
X
X NM2 = NSIZE2/2
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4600 I = 1,NM2
X DO 4550 J = 1,NSIZE1
X A2(J,I) = A2(J,I)*A2(J,I+NM2)
X 4550 CONTINUE
X 4600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = NM2*NSIZE1
X NLOOPS = NLOOPS+1
X
X T1 = 8.4
X XL = 5.
X TM = 4.5
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4700 K = 1,NSIZE2
X XU = ZERO(K)/T1
X A = .5*(XU+XL)
X BB = XU - XL
X DO 4650 II = 1,NSIZE1
X ADD = BB*C(II)
X X = A + ADD
X IY = X*SQRT(TM)
X IF (IY.GT.100 .OR. IY.LT.1) IY = 100
X F3(II,K,1) = MB(IY,K)
X X = A - ADD
X IY = X*SQRT(TM)
X IF (IY.GT.100 .OR. IY.LT.1) IY = 100
X F3(II,K,1) = MB(IY,K)
X 4650 CONTINUE
X XL = XU
X 4700 CONTINUE
X
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE2 + 5*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X FACT = 2.5
X EXJ = 2.1
X NSKIP = 2
X MSKIP = 2
X I2KS = 10
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4800 JJ = 1,NSIZE2
X DO 4750 MM = 1,NSIZE1
X JS = (JJ+MM)*2 - 3
X H = C11(JS) - C11(JS+10)
X C11(JS) = (C11(JS)+C11(JS+10))*FACT
X C11(JS+10) = (H*EXJ)*FACT
X 4750 CONTINUE
X 4800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 5*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X IWO0 = 100
X IW10 = 100
X IW20 = 100
X NATOMS = 5
X IDCPU = 1
X C2Z = 3.49
X C1 = 1.13
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 4900 JS = 1,NSIZE1
X J = JSAVE(JS)
X JW1 = 95 + J*5
X JWO = 95 + J*5
X JW2 = 95 + J*5
X
X G110 = GG(JS,10) + GG(JS,1)*C1
X G23 = GG(JS,2) + GG(JS,3)
X G45 = GG(JS,4) + GG(JS,5)
X FTEMP(JS,1) = G110 + GG(JS,11) + GG(JS,12) + C1*G23
X TT1 = GG(JS,1)*C2Z
X TT = G23*C2Z + TT1
X FTEMP(JS,2) = GG(JS,6) + GG(JS,7) + GG(JS,13) + TT + GG(JS,4)
X FTEMP(JS,3) = GG(JS,8) + GG(JS,9) + GG(JS,14) + TT + GG(JS,5)
X TT = G45*C2Z + TT1
X FZT(JWO,1) = FZT(JWO,1)-G110-GG(JS,13)-GG(JS,14)-C1*G45
X FZT(JW1,1)= FZT(JW1,1)-GG(JS,6)-GG(JS,8)-GG(JS,11)-TT-GG(JS,2)
X FZT(JW2,1)= FZT(JW2,1)-GG(JS,7)-GG(JS,9)-GG(JS,12)-TT-GG(JS,3)
X 4900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 39*NSIZE1
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5000 I = 2,NSIZE2
X L = I-1
X H = A2(I,I)
X DO 4970 J = 1,NSIZE2
X S = 0.0E0
X SI = 0.0E0
X DO 4920 K = 1,NSIZE1
X S = S + B2(K,I)*C2(K,J) - A2(K,I)*D2(K,J)
X SI = SI + B2(K,I)*D2(K,J) + A2(K,I)*C2(K,J)
X 4920 CONTINUE
X S = S*H
X SI = SI*H
X DO 4950 K = 1,NSIZE1
X C2(K,J) = C2(K,J) + S*B2(K,I) - SI*A2(K,I)
X D2(K,J) = D2(K,J) - SI*B2(K,I) + S*A2(K,I)
X 4950 CONTINUE
X 4970 CONTINUE
X 5000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = (NSIZE2-1)*NSIZE2*16*NSIZE1
X NLOOPS = NLOOPS+1
X
X EPS2 = 2.25
X EPS4 = 3.75
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5100 J = 1,NSIZE2
X DO 5050 K = 2,NSIZE1
X FIL = H3(K,J,1)*Q6(K,J) + H3(K,J,1)*Q6(K,J)
X G32 = EPS2*G3(K,J,1)*FIL
X G34 = EPS4*FIL
X C2(K,J) = G32*WR1(K,J) - G34*WR2(K,J)
X 5050 CONTINUE
X 5100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 9*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X P = PI
X R = PI
X S = PI
X ZC = PI
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5200 II = 1,NSIZE2
X S2 = S
X G = ZC*A1(II)
X H = ZC*P
X A1(II) = S*R
X S = A1(II)/R
X ZC = P/R
X P = ZC*B1(II) - S*G
X B1(II) = H + S*(ZC*G+S*B1(II))
X DO 5150 K = 1,NSIZE1
X H = A2(K,II)
X A2(K,II) = S*A2(K,II) + ZC*H
X A2(K,II) = ZC*A2(K,II) - S*H
X 5150 CONTINUE
X 5200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 13*NSIZE2 + 6*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X H = PI
X ZZ = 0
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5300 I = 1,NSIZE2
X DO 5270 J = 1,NSIZE2
X G = 0.0E0
X GI = 0.0E0
X
X DO 5230 K = 1,NSIZE1
X G = G + A2(K,J)*A2(K,I) + B2(K,J)*B2(K,I)
X GI = GI - A2(K,J)*B2(K,I) + B2(K,J)*A2(K,I)
X 5230 CONTINUE
X A1(I) = G/PI
X F1(I) = GI/PI
X ZZ = ZZ + A1(I)*D1(I) - F1(I)*B1(I)
X 5270 CONTINUE
X 5300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 8*NSIZE2*NSIZE1*NSIZE2 + 6*NSIZE2*NSIZE2
X NLOOPS = NLOOPS+1
X
X HH = PI
X Z = PI
X FI = PI
X DO 5320 I = 1,NSIZE2
X DO 5310 J = 1,NSIZE1
X AR(J,I) = 0
X AI(J,I) = 0
X 5310 CONTINUE
X 5320 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5400 I = 1,NSIZE2
X DO 5370 J = 1,NSIZE2
X G = A1(J) - HH*Z
X GI = P2(2,J) - HH*FI
X DO 5340 K = 1,NSIZE1
X AR(K,I)=HH-Z*A1(K)-G*AR(K,I)+FI*P2(2,K)+GI*AI(K,I)
X AI(K,I)=HH-Z*P2(2,K)-G*AI(K,I)-FI*A1(K)-GI*AR(K,I)
X 5340 CONTINUE
X 5370 CONTINUE
X 5400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE2*NSIZE2 + 16*NSIZE2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5500 IT = 1,NSIZE2
X TQI = B1(IT)
X UQI = F1(IT)
X DO 5450 IS = 1,NSIZE1
X A2(IS,IT) = UQI*TQI*A1(IS)
X 5450 CONTINUE
X 5500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5600 MP = 1,NSIZE2
X DO 5570 MQ = 1,NSIZE2
X VAL = T2(MQ)
X DO 5530 MI = 1,NSIZE1
X Q2(MI,MQ) = Q2(MI,MQ) + VAL*V(MI,MP)
X Q2(MI,MP) = Q2(MI,MP) + VAL*V(MI,MQ)
X 5530 CONTINUE
X 5570 CONTINUE
X 5600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE1*NSIZE2*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5700 K = 1,NSIZE1
X A1(K) = (A1(K)+F1(K)) + A2(K,2)*A2(K,5)*B1(K)
X 5700 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 3*NSIZE1
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5800 J = 1,NSIZE2
X DO 5770 K = 1,NSIZE3
X DO 5730 I = 1,NSIZE1
X E3(I,J,K) = E3(I,J,K) + A1(J)*D3(I,J,K)
X E3(I,J,K) = E3(I,J,K) + A1(J)*C3(I,J,K)
X CC = D3(I,J,K)
X CCC = C3(I,J,K)
X D3(I,J,K) = B3(I,J,K)
X C3(I,J,K) = A3(I,J,K)
X B3(I,J,K) = CC
X A3(I,J,K) = CCC
X 5730 CONTINUE
X 5770 CONTINUE
X 5800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 4*NSIZE1*NSIZE2*NSIZE3
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 5900 I = 1,NSIZE2
X DO 5870 J = 1,NSIZE2
X S = 0.
X DO 5830 K = 1,NSIZE1
X S = S + AM(K)*(DR(1,I,K)*DR(1,J,K)+DR(2,I,K)*DR(2,J,K)+
X 1 DR(3,I,K)*DR(3,J,K))
X 5830 CONTINUE
X GTEN(I,J) = S
X GTEN(J,I) = S
X 5870 CONTINUE
X 5900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 7*NSIZE1*NSIZE2*NSIZE2
X NLOOPS = NLOOPS+1
X
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6000 I = 1,NSIZE2
X SUM = 0.
X DO 5950 L = 1,NSIZE1
X SUM = SUM + A2(L,I)*B1(L)
X 5950 CONTINUE
X B1(I) = B1(I) - SUM
X 6000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 2*NSIZE1*NSIZE2 + NSIZE2
X NLOOPS = NLOOPS+1
X
X LMN = 2
X LMX = NSIZE2-1
X KMN = 2
X KMX = NSIZE1-1
X DTN = 4.56
X DO 6020 I = 1,NSIZE2
X DO 6010 J = 1,NSIZE1
X E2(J,I) = 1.
X F2(J,I) = 1.
X 6010 CONTINUE
X 6020 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6100 L = 2, LMX
X DO 6060 K = 2, KMX
X A1(K) = (A2(K,L)+B2(K,L))*(C2(K,L-1)-C2(K-1,L)) + (A2(K+1,L) +
X 1 B2(K+1,L))*(C2(K+1,L)-C2(K,L-1)) + (A2(K,L+1)+B2(K,L+1))*
X 2 (C2(K-1,L)-C2(K,L+1)) + (A2(K+1,L+1)+B2(K+1,L+1))*
X 3 (C2(K,L+1)-C2(K+1,L))
X B1(K) = (A2(K,L)+B2(K,L))*(D2(K,L-1)-D2(K-1,L)) + (A2(K+1,L) +
X 1 B2(K+1,L))*(D2(K+1,L)-D2(K,L-1)) + (A2(K,L+1)+B2(K,L+1))*
X 2 (D2(K-1,L)-D2(K,L+1)) + (A2(K+1,L+1)+B2(K+1,L+1))*
X 3 (D2(K,L+1)-D2(K+1,L))
X F1(K) = E2(K,L)*F2(K,L) + E2(K+1,L)*F2(K+1,L) + E2(K,L+1)*
X 1 F2(K,L+1) + E2(K+1,L+1)*F2(K+1,L+1)
X F1(K) = 2./F1(K)
X A1(K) = -A1(K)*F1(K)
X B1(K) = B1(K)*F1(K)
X G2(K,L) = G2(K,L) + DTN*A1(K)
X WR2(K,L) = WR2(K,L) + DTN*B1(K)
X 6060 CONTINUE
X 6100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 44*(NSIZE2-1)*(NSIZE1-1)
X NLOOPS = NLOOPS+1
X
X LMNP = 2
X LMX = NSIZE2-1
X KMNP = 1
X KMX = NSIZE1
X DO 6120 I = 1,NSIZE1
X DO 6110 L = 1,NSIZE2
X C2(I,L) = 2.5
X 6110 CONTINUE
X 6120 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6200 L = 2, LMX
X DO 6160 K = 1,KMX
X A1(K) = C2(K,L) + D2(K,L) + D2(K,L-1)*(1.-A2(K,L-1))
X A2(K,L) = D2(K,L)/A1(K)
X B2(K,L) = (C2(K,L)*E2(K,L)+D2(K,L-1)*B2(K,L-1))/A1(K)
X 6160 CONTINUE
X 6200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 9*(NSIZE2-1)*NSIZE1
X NLOOPS = NLOOPS+1
X
X LCURR = 1
X DVOL = 3.52
X DTDP = 7.825
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6300 I = 1,NSIZE2
X UQ(I) = 0.
X DUQ(I) = 0.
X TQ(I) = 0.
X DTQ(I) = 0.
X DO 6230 JK = 1,NSIZE1
X A2(JK,I) = C2(JK,I)*FTP(I) + D2(JK,I)*FPP(I)
X B2(JK,I) = D2(JK,I)*FTP(I) + E2(JK,I)*FPP(I)
X IF (LCURR .EQ. 1) THEN
X UQ(I) = UQ(I) - DTDP*A2(JK,I)
X DUQ(I) = DUQ(I) + DTDP*B2(JK,I)
X ENDIF
X IF (LCURR .EQ. 2) THEN
X UQ(I) = UQ(I) + DTDP*A2(JK,I)
X DUQ(I) = DUQ(I) - DTDP*B2(JK,I)
X ENDIF
X FPP(I) = FPP(I)
X TQ(I) = TQ(I) - DTDP*F2(JK,I)
X 6230 CONTINUE
X DO 6270 JK = 1,NSIZE1
X DTQ(I) = DTQ(I) + 0.5*G2(JK,I)*F2(JK,I)*DVOL
X 6270 CONTINUE
X 6300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 16*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X
X NN = NSIZE2
X KE = 1
X LS = 1
X LE = NSIZE1
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6400 I = 1,NN
X DO 6350 L = 1,LE
X Q6(L,I) = F(L,1,I) - E(L,I,1)*F(L,5,1) - E(L,I,2)*F(L,5,2) -
X 1 E(L,I,3)*F(L,5,3) - E(L,I,4)*F(L,5,4) - E(L,I,5)*F(L,5,5)
X 6350 CONTINUE
X 6400 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 10*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X EPS = 3.111
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6500 I = 1,NSIZE2
X DO 6430 J = 1,NSIZE3
X DO 6410 L = 1,NSIZE1
X D3(L,I,J) = D3(L,I,J) - D3(L,I,J)*D3(L,I,J)
X 6410 CONTINUE
X DO 6420 L = 1,NSIZE1
X D3(L,I,J) = D3(L,I,J)*D3(L,1,J)
X 6420 CONTINUE
X 6430 CONTINUE
X
X DO 6440 L = 1,NSIZE1
X A1(L) = EPS*D3(L,1,J)
X 6440 CONTINUE
X DO 6460 J = 1,NSIZE3
X DO 6450 L = 1,NSIZE1
X D3(L,I,J) = D3(L,I,J) - D3(L,I,J)**2
X 6450 CONTINUE
X 6460 CONTINUE
X DO 6480 L = 1,NSIZE1
X D3(L,1,J) = ABS(A1(L)+D3(L,1,J))
X 6480 CONTINUE
X 6500 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X NALL = NSIZE1*NSIZE2*NSIZE3
X FLOOPS(NLOOPS) = 5*NALL + 2*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
X
X DO 6520 I = 1,NSIZE1
X DO 6520 J = 1,NSIZE2
X 6520 AR(I,J) = 1.0
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6600 J = 1,NSIZE2
X A1(J) = 0.0
X DO 6530 I = 1,NSIZE1
X A2(I,J) = C2(I,J)*(D2(I,J)*(B2(I,J)-B1(I))+E2(I,J)*(B2(I,J)-
X 1 F1(I))+F2(I,J)*(B2(I,J)-D1(I))+G2(I,J)*(B2(I,J)-C(I))-
X 2 AR(I,J))
X 6530 CONTINUE
X DO 6570 I = 1,NSIZE1
X A1(J) = A1(J) + A2(I,J)*A2(I,J)
X 6570 CONTINUE
X 6600 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 15*NSIZE1*NSIZE2
X NLOOPS = NLOOPS+1
X
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6700 J4 = 1,16
X DO 6650 J3 = 1,NSIZE1
X A1(J3) = A1(J3) + E11((J3-1)*16+J4)*P11((J3-1)*16+J4)
X B1(J3) = B1(J3) + F11((J3-1)*16+J4)*P11((J3-1)*16+J4)
X F1(J3) = F1(J3) + D11((J3-1)*16+J4)*P11((J3-1)*16+J4)
X D1(J3) = D1(J3) + G11((J3-1)*16+J4)*P11((J3-1)*16+J4)
X DSQ(J3) = DSQ(J3) + H11((J3-1)*16+J4)*P11((J3-1)*16+J4)
X 6650 CONTINUE
X 6700 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 10*16*NSIZE1
X NLOOPS = NLOOPS+1
X
X IRAD = NSIZE3
X NOX = NSIZE1
X NOY = NSIZE2
X NOZ = NSIZE3
X IF (NSIZE1 .EQ. NSIZE3) IRAD = 1
X INNER = NSIZE1 - 2*IRAD
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6800 IY = 1,NOY
X DO 6780 IZ = 1,NOZ
X DO 6720 IX = 1 + IRAD, NOX - IRAD
X A11((IZ-1)*NOY*NOX+(IY-1)*NOX+IX) = B11((IZ-1)*NOY*NOX+
X 1 (IY-1)*NOX+IX)*A1(1)
X 6720 CONTINUE
X
X DO 6760 K = 1,IRAD
X DO 6740 IX = 1 + IRAD, NOX - IRAD
X A11((IZ-1)*NOY*NOX+(IY-1)*NOX+IX) = A11((IZ-1)*NOY*NOX+
X 1 (IY-1)*NOX+IX)+(B11((IZ-1)*NOY*NOX+(IY-1)*NOX+IX+K)+
X 2 B11((IZ-1)*NOY*NOX+(IY-1)*NOX+IX-K))*A1(K+1)
X 6740 CONTINUE
X 6760 CONTINUE
X 6780 CONTINUE
X 6800 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = IRAD*NSIZE2*(INNER+2*IRAD*INNER)
X NLOOPS = NLOOPS+1
X
X DO 6830 K = 1,NSIZE3
X DO 6820 J = 1,NSIZE2
X DO 6810 I = 1,NSIZE1
X D3(I,J,K) = 1.0
X B3(I,J,K) = 1.0
X 6810 CONTINUE
X 6820 CONTINUE
X 6830 CONTINUE
X NRHS = NSIZE1
X NMAT = NSIZE2
X NNN = NSIZE3
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 6900 L = 1,NMAT
X DO 6860 K = 1,NNN
X DO 6840 I = 1,NRHS
X D3(I,L,K) = D3(I,L,K)*B3(I,1,K)
X 6840 CONTINUE
X DO 6850 I = 1,NRHS
X D3(I,L,K) = D3(I,L,K) - B3(I,1,K)*D3(I,L,K)
X 6850 CONTINUE
X 6860 CONTINUE
X
X DO 6890 K = NNN,1,-1
X DO 6870 I = 1,NRHS
X D3(I,L,K) = D3(I,L,K)*B3(I,1,K)
X 6870 CONTINUE
X DO 6880 I = 1,NRHS
X D3(I,L,K) = D3(I,L,K) - B3(I,1,K)*D3(I,L,K)
X 6880 CONTINUE
X 6890 CONTINUE
X 6900 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 6*NSIZE1*NSIZE2*NSIZE3
X NLOOPS = NLOOPS+1
X
X TPI = PI
X DO 6910 I = 1,NSIZE3
X A2(1,I) = .2
X A2(2,I) = .2
X A2(3,I) = .2
X 6910 CONTINUE
X DO 6920 I = 1,NSIZE1
X P2(1,I) = 1.
X P2(2,I) = 1.
X P2(3,I) = 1.
X 6920 CONTINUE
X OMEGA = PI
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 7000 NT = 1,NSIZE2
X DO 6970 IG = 1,NSIZE3
X CMPLX2(IG,NT) = (0.0,0.0)
X DO 6940 IN = 1,NSIZE1
X ARG = (A2(1,IG)*P2(1,IN)+A2(2,IG)*P2(2,IN)+A2(3,IG)*
X 1 P2(3,IN))*TPI
X CMPLX2(IG,NT)=CMPLX2(IG,NT)+CMPLX(COS(ARG),(-SIN(ARG)))
X
X 6940 CONTINUE
X CMPLX2(IG,NT) = CMPLX2(IG,NT)/OMEGA
X 6970 CONTINUE
X 7000 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 7*NSIZE1*NSIZE2*NSIZE3 + NSIZE3*NSIZE2
X NLOOPS = NLOOPS+1
X
X L = 0
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 7100 I = 1,NSIZE1
X DO 7070 J = 1,NSIZE2
X S = 0.
X DO 7030 K = 1,NSIZE2
X S = S + A2(I,K)*A1(K)*B2(J,K)
X 7030 CONTINUE
X B11(J) = S
X C2(I,J) = S
X 7070 CONTINUE
X 7100 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 3*NSIZE1*NSIZE2*NSIZE2
X NLOOPS = NLOOPS+1
X
X MT = NSIZE2-1
X MX = NSIZE3/2
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 7200 J = 1,MT + 1
X DO 7170 K = 1,2*MX
X
X J1 = J - 1
X K1 = K - 1
X IF (K1 .GT. MX) K1 = K1 - 2*MX
X DO 7130 I = 1,NSIZE1
X CMP2 = EXP((0.,1.)*(J1*PI/(2*MT)+K1*PI/(2*MX)))
X CMP1(I) = D3(I,J,K) + (0.,1.)*B3(I,J,K)
X CMP1(I) = CMP2*CMP1(I)
X D3(I,J,K) = CMP1(I)
X B3(I,J,K) = (0.,-1.)*CMP1(I)
X CMP1(I) = D3(I,J,K) + (0.,1.)*B3(I,J,K)
X CMP1(I) = CMP2*CMP1(I)
X D3(I,J,K) = CMP1(I)
X B3(I,J,K) = (0.,-1.)*CMP1(I)
X
X CMP1(I) = D3(I,J,K) + (0.,1.)*B3(I,J,K)
X CMP1(I) = CMP2*CMP1(I)
X D3(I,J,K) = CMP1(I)
X B3(I,J,K) = (0.,-1.)*CMP1(I)
X 7130 CONTINUE
X 7170 CONTINUE
X 7200 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
X FLOOPS(NLOOPS) = 31*NSIZE1*NSIZE2*NSIZE3
X NLOOPS = NLOOPS+1
X
X DO 7220 I = 1,NSIZE2
X DO 7210 J = 1,NSIZE1
X C2(J,I) = 0.1
X 7210 CONTINUE
X 7220 CONTINUE
C ------------------------------------------------------------------------------
X TSTART = RTC()
X DO 7300 I = 1,NSIZE2
X DO 7250 J = 1,NSIZE1
X A2(J,I) = ABS(C2(J,I))
X B2(J,I) = SIN(C2(J,I))
X B2(J,I) = COS(C2(J,I))
X B2(J,I) = SQRT(C2(J,I))
X B2(J,I) = EXP(C2(J,I))
X B2(J,I) = LOG(C2(J,I))
X 7250 CONTINUE
X 7300 CONTINUE
X TLOOPS(NLOOPS) = RTC()-TSTART
C "45" FROM HARDWARE PERFORMANCE MONITOR FOR THIS SPECIFIC DATA CASE
X FLOOPS(NLOOPS) = 45*NSIZE1*NSIZE2
X
X LOOPS=1000
X GM = 1.
X DO 9900 I = 1,NLOOPS
X TIME = (TLOOPS(I)*CLOCK)
X TWT = TWT + TIME
X TFLOPS = TFLOPS + FLOOPS(I)
X MFLOPS = (FLOOPS(I)/TIME)*1.E-6
X GM = GM * MFLOPS
X PRINT 12, I,LOOPS,TIME,MFLOPS
X LOOPS = LOOPS +100
X 9900 CONTINUE
X
X MFLOPS = (TFLOPS/TWT)*1.E-06
X GM = GM**(1./64.)
X PRINT 14, NCASE, TWT, MFLOPS
X PRINT 16, GM
X
X RETURN
X 10 FORMAT(/' Case',I3,': NSIZE1 =',I5,', NSIZE2 =',I4,
X 1 ', NSIZE3 =',I3/)
X 12 FORMAT(I5,') "DO',I5,'" Loop Wallclock',F12.7,
X 1 's, ',F9.1,' MFlops')
X 14 FORMAT(/' Case',I3,' Aggregates: Wallclock',F9.2,'s, ',
X 1 F9.1,' MFlops')
X 16 FORMAT(/' Geometric Mean:',2x,f9.2,///)
X END
X
X
END_OF_FILE
if test 42103 -ne `wc -c <'loops2.f'`; then
echo shar: \"'loops2.f'\" unpacked with wrong size!
fi
# end of 'loops2.f'
fi
echo shar: End of shell archive.
exit 0