C ALGORITHM 651, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 13, NO. 3, P. 235. SUBROUTINE HFFT3 (COEFU, PRHS, BRHS, AX, BX, AY, BY, AZ, BZ, * NX, NY, NZ, BCTY, IORDER, U, LDXU, LDYU, WORK, * NWORK, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C HFFT2 = 2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT2A = 2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C HFFT3 = 3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT3A = 3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C * C C P U R P O S E C ------------- C C HFFT3 SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES C ON A THREE-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION C OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS. C C C D E S C R I P T I O N C --------------------- C C HFFT3 SOLVES THE EQUATION C C 2 2 2 C D U D U D U C --- + --- + --- + COEFU*U = G C 2 2 2 C DX DY DZ C C C IN THE BOX (AX,BX)X(AY,BY)X(AZ,BZ) C C C ----------------------------. C / /: C / / : C / TOP / : C / (4) / : C / / : C / Y=BY / : C / / : C ---------------------------- : C : : : C : : : C : : RIGHT : C : : (1) : C : FRONT : : C LEFT : (5) : X=BX : C (3) : : : C : Z=BZ : / C X=AX : : / C : : / C : : / C : : / C : : / C : : / C ----------------------------/ C BOTTOM (2) Y=AY C C C WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN C (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS. C C THE OUTPUT OF THIS PROGRAM IS A THREE-DIMENSIONAL ARRAY GIVING C ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J),Z(K)), C FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ, WHERE C C X(I) = AX + (I-1)*HX C Y(J) = AY + (J-1)*HY C Z(K) = AZ + (K-1)*HZ C HX = (BX-AX)/(NX-1) C HY = (BY-AY)/(NY-1) C HZ = (BZ-AZ)/(NZ-1) C C THE USER MUST CHOOSE NX, NY, AND NZ SO THAT THE GRID SPACING IS C THE SAME IN EACH OF X, Y, AND Z, I.E., HX = HY = HZ. C C WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE C PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO C OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION C OF MINIMUM INFINITY NORM IS RETURNED. C C THE SOLUTION IS COMPUTED USING A FOURTH ORDER ACCURATE FINITE C DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. THE RESULTING C SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING FAST FOURIER C TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE FACT THAT C NX-1 AND NZ-1 ARE HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES). C C C P A R A M E T E R S C ------------------- C C COEFU REAL SCALAR (INPUT) C THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION. C C PRHS REAL FUNCTION OF X,Y,Z (INPUT) C RETURNS THE RIGHT-HAND SIDE OF THE DIFFERENTIAL EQUATION C FOR ANY (X,Y,Z) IN THE DOMAIN OR ON THE BOUNDARY (SEE C DESCRIPTION BELOW). THE NAME OF THIS FUNCTION MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. C C BRHS REAL FUNCTION OF K,X,Y,Z (INPUT) C RETURNS THE RIGHT-HAND SIDE OF THE BOUNDARY CONDITION AT C THE POINT (X,Y,Z) ON THE K-TH SIDE OF THE DOMAIN (SEE C DESCRIPTION BELOW). THE NAME OF THIS FUNCTION MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. C C AX REAL SCALAR (INPUT) .LT. BX C THE VALUE OF X ALONG THE LEFT SIDE OF THE DOMAIN. C C BX REAL SCALAR (INPUT) C THE VALUE OF X ALONG THE RIGHT SIDE OF THE DOMAIN. C C AY REAL SCALAR (INPUT) .LT. BY C THE VALUE OF Y ALONG THE BOTTOM SIDE OF THE DOMAIN. C C BY REAL SCALAR (INPUT) C THE VALUE OF Y ALONG THE TOP SIDE OF THE DOMAIN. C C AZ REAL SCALAR (INPUT) .LT. BZ C THE VALUE OF Z ALONG THE FRONT SIDE OF THE DOMAIN. C C BZ REAL SCALAR (INPUT) C THE VALUE OF Z ALONG THE BACK SIDE OF THE DOMAIN. C C NX INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN X. C (THE NUMBER OF SUB-INTERVALS IN X IS THEN NX-1.) C NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C NY INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Y. C (THE NUMBER OF SUB-INTERVALS IN Y IS THEN NY-1.) C C NZ INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Z. C (THE NUMBER OF SUB-INTERVALS IN Z IS THEN NZ-1.) C NZ SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE C DOMAIN AS FOLLOWS. C C BCTY(1) = TYPE ON RIGHT SIDE (X=BX) C BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY) C BCTY(3) = TYPE ON LEFT SIDE (X=AX) C BCTY(4) = TYPE ON TOP SIDE (Y=BY) C BCTY(5) = TYPE ON FRONT SIDE (Z=BZ) C BCTY(6) = TYPE ON BACK SIDE (Z=AZ) C C POSSIBLE VALUES ARE C C 1 == U PRESCRIBED C 2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR C DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) OR C DU/DZ PRESCRIBED (FOR BCTY(5) AND BCTY(6)) C 3 == PERIODIC C C IORDER INTEGER SCALAR (INPUT) C THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE C APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE C C 2 == SECOND ORDER ACCURATE COMPACT 9-POINT DIFFERENCES C 4 == FOURTH ORDER ACCURATE COMPACT 9-POINT DIFFERENCES C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ+2 (INPUT/OUTPUT) C ON INPUT, U(I,J,K) CONTAINS THE VALUE OF THE RIGHT HAND C SIDE OF THE PARTIAL DIFFERENTAIL EQUATION AT THE (I,J,K)TH C GRID POINT. THAT IS, C C U(I,J,K) = G(X(I),Y(J),Z(K)) C C FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ. C ON OUTPUT, U(I,J,K) IS THE VALUE OF THE COMPUTED SOLUTION C AT THE POINT (X(I),Y(J),Z(K)). THE PLANES U(NX+1,*,*), C U(NX+2,*,*), U(*,NY+1,*), U(*,NY+2,*), U(*,*,NZ+1), AND C U(*,*,NZ+2) ARE USED AS WORKING STORAGE. C C LDXU INTEGER SCALAR (INPUT) .GE. NX+2 C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C LDYU INTEGER SCALAR (INPUT) .GE. NY+2 C THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C WORK REAL ARRAY OF SIZE NWORK. C WORKING STORAGE REQUIRED BY HFFT3. C C NWORK INTEGER SCALAR (INPUT) C .GE. (NX+1)*(NY+1)*(NZ+1)*(IORDER-2)/2 C + 2*(NX*NY+NX*NZ+NY*NZ) C + MAX( (NX+1)*(NY+1)*(IORDER-2), C (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 ) C THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING C PROGRAM. THIS MAY BE REDUCED BY 4*NY IF COEFU.LE.0. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY C CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE C PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE C RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED. C THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT C SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN C ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN C ADDITIVE CONSTANT. C 1 == WARNING. COEFU.GT.0 A SOLUTION MAY NOT EXIST IF C COEFU IS AN EIGENVALUE OF THE LAPLACIAN. IF COEFU C IS NEAR ONE OF THESE VALUES THEN THE COMPUTED C SOLUTION MAY BE UNRELIABLE. C 0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION. C -1 == ERROR. NX.LT.4 C -2 == ERROR. NY.LT.4 C -3 == ERROR. NZ.LT.4 C -4 == ERROR. LDXU.LT.NX+2 C -5 == ERROR. LDYU.LT.NY+2 C -6 == ERROR. IORDER NOT 2 OR 4. C -7 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3. C -8 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON C ONE SIDE OF DOMAIN BUT NOT ON THE OPPOSITE. C -9 == ERROR. NWORK TOO SMALL. C -10 == ERROR. BX.LT.AX C -11 == ERROR. BY.LT.AY C -12 == ERROR. BZ.LT.AZ C -13 == ERROR. GRID SIZE IN Y NOT SAME AS IN X. C -14 == ERROR. GRID SIZE IN Z NOT SAME AS IN X. C C C U S E R - D E F I N E D F U N C T I O N S C ------------------------------------------- C C THE RIGHT HAND SIDE (FORCING FUNCTION) OF THE PARTIAL C DIFFERENTIAL EQUATION IS SPECIFIED BY THE FUNCTION PRHS. C C REAL FUNCTION PRHS (X,Y,Z) C REAL X,Y,Z C PRHS = RIGHT SIDE OF THE PDE AT (X,Y,Z) C RETURN C END C C THE VALUE OF THE SOLUTION OR ITS FIRST DERIVATIVE ALONG THE C EDGES OF THE DOMAIN WHERE BCTY=1 OR 2 IS SUPPLIED VIA THE C FUNCTION BRHS. C C REAL FUNCTION BRHS (K,X,Y,Z) C INTEGER K C REAL X,Y,Z C BRHS = RIGHT HAND SIDE OF KTH BOUNDARY CONDITION C (SEE BCTY) AT THE POINT (X,Y,Z) C RETURN C END C C C E X T E R N A L R E F E R E N C E S C ------------------------------------- C C HFFT3A,FDIS3,HDIS3,FD3N, C STORD3,FD3D,FD2D,FD2DA,HD3N, C REFL3,MDALG3,MDALG2,EVDISC, C TRISOL,TRSALL,TRSOLG,TRSOLP, C SGPSL,FFTI,FFTB,FFTF -- THIS PACKAGE C C RFFTI,RFFTF,RFFTB, C SINTI,SINT,COSTI,COST, C SINQI,SINQF,SINQB, C COSQI,COSQF,COSQB -- FFTPACK (SEE REF. 2) C C R1MACH -- MACHINE CONSTANTS (SEE REF. 3) C C PRHS,BRHS -- USER-SUPPLIED C C C P O R T A B I L I T Y C --------------------- C C THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977). C ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE C FUNCTION R1MACH (SEE REF. 3). C C C R E F E R E N C E S C ------------------- C C 1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD C FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS C II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS, C ORLANDO, FLA., 1984, 35-44. C C 2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE C PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS C ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3). C FFTPACK IS DESCRIBED IN C C P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL C COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, C PP. 51-83. C C FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE, C COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH, C BOX 3000, BOULDER, CO 80303, USA. C C 3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK C FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978), C PP. 177-188. C C 4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS, C HOLT, RINEHART AND WINSTON, NEW YORK, 1967. C C C A U T H O R / V E R S I O N C ----------------------------- C C RONALD F. BOISVERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C GAITHERSBURG, MD 20899 C USA C C ORIGINAL DECEMBER 1985 C REVISED APRIL 1987 C C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, NZ, BCTY(6), IORDER, LDXU, LDYU, NWORK, INFO REAL * COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,*), WORK(NWORK) C C ... LOCAL VARIABLES C INTEGER LOCGH, LOCBD1, LOCBD2, LOCBD3, LOCBD4, LOCBD5, LOCBD6, * NEEDED, NWORKA, NXM1, NYM1, NZM1, NXP1, NYP1, NZP1 REAL * EPSM, R1MACH, PRHS, BRHS, H, HX, HY, HZ, AXH, AYH, AZH, * X, Y, Z C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C EPSM = R1MACH(4) C NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 NXP1 = NX + 1 NYP1 = NY + 1 NZP1 = NZ + 1 C H = (BX-AX)/REAL(NXM1) C LOC GH = 1 LOC BD1 = LOC GH IF (IORDER .EQ. 4) LOC BD1 = LOC GH + NXP1*NYP1*NZP1 LOC BD2 = LOC BD1 + NY*NZ LOC BD3 = LOC BD2 + NX*NZ LOC BD4 = LOC BD3 + NY*NZ LOC BD5 = LOC BD4 + NX*NZ LOC BD6 = LOC BD5 + NX*NY LOC WRK = LOC BD6 + NX*NY NEEDED = LOC WRK + MAX( NXP1*NXP1*(IORDER-2), * (NX+3)*(NY+5) + 5*NY + (NX+NZ)/2 + 15 ) - 1 NWORKA = NWORK - LOCWRK + 1 C C C --------------------------- C CHECK VALIDITY OF ARGUMENTS C --------------------------- C INFO = 0 IF (NX .LT. PRDC) GO TO 901 IF (NY .LT. PRDC) GO TO 902 IF (NZ .LT. PRDC) GO TO 903 IF (LDXU .LT. NX+2) GO TO 904 IF (LDYU .LT. NY+2) GO TO 905 IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 906 DO 10 K=1,6 IF ((BCTY(K) .LT. DRCH) .OR. (BCTY(K) .GT. PRDC)) GO TO 907 10 CONTINUE IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT ) .NE. PRDC)) .OR. * ((BCTY(LEFT ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR. * ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP ) .NE. PRDC)) .OR. * ((BCTY(TOP ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) .OR. * ((BCTY(FRONT ) .EQ. PRDC) .AND. (BCTY(BACK ) .NE. PRDC)) .OR. * ((BCTY(BACK ) .EQ. PRDC) .AND. (BCTY(FRONT ) .NE. PRDC)) ) * GO TO 908 IF (NWORK .LT. NEEDED) GO TO 909 IF (BX .LE. AX) GO TO 910 IF (BY .LE. AY) GO TO 911 IF (BZ .LE. AZ) GO TO 912 HX = H HY = (BY-AY)/REAL(NYM1) HZ = (BZ-AZ)/REAL(NZM1) IF (ABS(HX-HY) .GT. EPSM) GO TO 913 IF (ABS(HX-HZ) .GT. EPSM) GO TO 914 C C C ------------------ C COMPUTE RHS OF PDE C ------------------ C C ... AT GRID POINTS C DO 100 K=1,NZ Z = AZ + REAL(K-1)*H DO 100 J=1,NY Y = AY + REAL(J-1)*H DO 100 I=1,NX X = AX + REAL(I-1)*H U(I,J,K) = PRHS(X,Y,Z) 100 CONTINUE C C ... AT HALF GRID POINTS C IF (IORDER .EQ. 4) THEN AXH = AX + 0.50E0*H AYH = AY + 0.50E0*H AZH = AZ + 0.50E0*H DO 200 K=1,NZM1 Z = AZH + REAL(K-1)*H DO 200 J=1,NYM1 Y = AYH + REAL(J-1)*H LOC = LOC GH + (K*NYP1 + J)*NXP1 DO 200 I=1,NXM1 X = AXH + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = PRHS(X,Y,Z) 200 CONTINUE ENDIF C C C ------------------- C STORE BOUNDARY DATA C ------------------- C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .NE. PRDC) THEN DO 265 K=1,NZ Z = AZ + REAL(K-1)*H LOC = LOC BD2 + (K-1)*NX - 1 DO 265 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(BOTTOM,X,AY,Z) 265 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .NE. PRDC) THEN DO 275 K=1,NZ Z = AZ + REAL(K-1)*H LOC = LOC BD4 + (K-1)*NX - 1 DO 275 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(TOP,X,BY,Z) 275 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .NE. PRDC) THEN DO 285 K=1,NZ Z = AZ + REAL(K-1)*H LOC = LOC BD3 + (K-1)*NY - 1 DO 285 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(LEFT,AX,Y,Z) 285 CONTINUE ENDIF C C ... RIGHT SIDE C IF (BCTY(RIGHT) .NE. PRDC) THEN DO 295 K=1,NZ Z = AZ + REAL(K-1)*H LOC = LOC BD1 + (K-1)*NY - 1 DO 295 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(RIGHT,BX,Y,Z) 295 CONTINUE ENDIF C C ... FRONT SIDE C IF (BCTY(FRONT) .NE. PRDC) THEN DO 305 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC BD5 + (J-1)*NX - 1 DO 305 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(FRONT,X,Y,BZ) 305 CONTINUE ENDIF C C ... BACK SIDE C IF (BCTY(BACK) .NE. PRDC) THEN DO 315 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC BD6 + (J-1)*NX - 1 DO 315 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(BACK,X,Y,AZ) 315 CONTINUE ENDIF C C C ---------------- C CALL FAST SOLVER C ---------------- C CALL HFFT3A(COEFU,NX,NY,NZ,H,WORK(LOCGH),NXP1,NYP1,BCTY, * WORK(LOCBD1),WORK(LOCBD2),WORK(LOCBD3),WORK(LOCBD4), * WORK(LOCBD5),WORK(LOCBD6),NX,NY,IORDER,U,LDXU,LDYU, * WORK(LOCWRK),NWORKA,INFO) C C C ----------- C NORMAL EXIT C ----------- C WORK(1) = WORK(LOCWRK) GO TO 999 C C C ----------- C ERROR EXITS C ----------- C 901 CONTINUE INFO = -1 GO TO 999 C 902 CONTINUE INFO = -2 GO TO 999 C 903 CONTINUE INFO = -3 GO TO 999 C 904 CONTINUE INFO = -4 GO TO 999 C 905 CONTINUE INFO = -5 GO TO 999 C 906 CONTINUE INFO = -6 GO TO 999 C 907 CONTINUE INFO = -7 GO TO 999 C 908 CONTINUE INFO = -8 GO TO 999 C 909 CONTINUE INFO = -9 GO TO 999 C 910 CONTINUE INFO = -10 GO TO 999 C 911 CONTINUE INFO = -11 GO TO 999 C 912 CONTINUE INFO = -12 GO TO 999 C 913 CONTINUE INFO = -13 GO TO 999 C 914 CONTINUE INFO = -14 GO TO 999 C 999 CONTINUE RETURN END SUBROUTINE HFFT3A (COEFU, NX, NY, NZ, H, GH, LDXGH, LDYGH, BCTY, * BD1, BD2, BD3, BD4, BD5, BD6, LDXBD, LDYBD, * IORDER, U, LDXU, LDYU, WORK, NWORK, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C HFFT2 = 2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT2A = 2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C HFFT3 = 3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT3A = 3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C P U R P O S E C ------------- C C HFFT3A SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES C ON A THREE-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION C OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS. C C C D E S C R I P T I O N C --------------------- C C HFFT3A SOLVES THE EQUATION C C 2 2 2 C D U D U D U C --- + --- + --- + COEFU*U = G C 2 2 2 C DX DY DZ C C C IN THE BOX (AX,BX)X(AY,BY)X(AZ,BZ) C C C ----------------------------. C / /: C / / : C / TOP / : C / (4) / : C / / : C / Y=BY / : C / / : C ---------------------------- : C : : : C : : : C : : RIGHT : C : : (1) : C : FRONT : : C LEFT : (5) : X=BX : C (3) : : : C : Z=BZ : / C X=AX : : / C : : / C : : / C : : / C : : / C : : / C ---------------------------- C BOTTOM (2) Y=AY C C C WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN C (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS. C C THE OUTPUT OF THIS PROGRAM IS A THREE-DIMENSIONAL ARRAY GIVING C ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J),Z(K)), C FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ, WHERE C C X(I) = AX + (I-1)*H C Y(J) = AY + (J-1)*H C Z(K) = AZ + (K-1)*H C C WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE C PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO C OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION C OF MINIMUM INFINITY NORM IS RETURNED. C C THE SOLUTION IS COMPUTED USING A FOURTH ORDER ACCURATE FINITE C DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. THE RESULTING C SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING FAST FOURIER C TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE FACT THAT C NX-1 AND NZ-1 ARE HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES). C C C P A R A M E T E R S C ------------------- C C COEFU REAL SCALAR (INPUT) C THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION. C C NX INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN X. C (THE NUMBER OF SUB-INTERVALS IN X IS THEN NX-1.) C NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C NY INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Y. C (THE NUMBER OF SUB-INTERVALS IN Y IS THEN NY-1.) C C NZ INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Z. C (THE NUMBER OF SUB-INTERVALS IN Z IS THEN NZ-1.) C NZ SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C H REAL SCALAR (INPUT) C THE SPACE BETWEEN ADJACENT GRID LINES (IN X, Y, AND Z). C C GH REAL ARRAY OF SIZE LDXGH BY LDYGH BY NZ+1 (INPUT) C THE RIGHT HAND SIDE OF THE PDE AT HALF GRID POINTS. C G(I+1,J+1,K+1) IS THE VALUE OF THE RIGHT HAND SIDE AT THE C (I,J,K)TH HALF GRID POINT, I=1,..,NX-1, J=1,..,NY-1, C K=1,..,NZ-1. THAT IS, C C GH(I+1,J+1,K+1) = G(XH(I),YH(J),ZH(K)) C XH(I) = AX + (I-0.5)*H C YH(J) = AY + (J-0.5)*H C ZH(K) = AZ + (K-0.5)*H C C PLANES GH(1,*,*), GH(NX+1,*,*), GH(*,1,*), GH(*,NY+1,*), C GH(*,*,1), AND GH(*,*,NZ+2) ARE USED FOR WORKING STORAGE. C GH IS NOT USED WHEN IORDER=2. C C LDXGH INTEGER SCALAR (INPUT) .GE. NX+1 C THE LEADING DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C LDYGH INTEGER SCALAR (INPUT) .GE. NY+1 C THE SECOND DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE C DOMAIN AS FOLLOWS. C C BCTY(1) = TYPE ON RIGHT SIDE (X=BX) C BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY) C BCTY(3) = TYPE ON LEFT SIDE (X=AX) C BCTY(4) = TYPE ON TOP SIDE (Y=BY) C BCTY(5) = TYPE ON FRONT SIDE (Z=BZ) C BCTY(6) = TYPE ON BACK SIDE (Z=AZ) C C POSSIBLE VALUES ARE C C 1 == U PRESCRIBED C 2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR C DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) OR C DU/DZ PRESCRIBED (FOR BCTY(5) AND BCTY(6)) C 3 == PERIODIC C C BD1 REAL ARRAY OF SIZE LDYBD BY NZ (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE RIGHT SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(1) VALUE STORED C ------------------------------ C 1 U C 2 DU/DX C 3 NONE C C BD1(J,K) GIVES THE VALUE AT THE POINT (BX,Y(J),Z(K)). C C BD2 REAL ARRAY OF SIZE LDXBD BY NZ (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE BOTTOM SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(2) VALUE STORED C ------------------------------ C 1 U C 2 DU/DY C 3 NONE C C BD2(I,K) GIVES THE VALUE AT THE POINT (X(I),AY,Z(K)). C C BD3 REAL ARRAY OF SIZE LDYBD BY NZ (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE LEFT SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(3) VALUE STORED C ------------------------------ C 1 U C 2 DU/DX C 3 NONE C C BD3(J,K) GIVES THE VALUE AT THE POINT (AX,Y(J),Z(K)). C C BD4 REAL ARRAY OF SIZE LDXBD BY NZ (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE TOP SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(4) VALUE STORED C ------------------------------ C 1 U C 2 DU/DY C 3 NONE C C BD4(I,K) GIVES THE VALUE AT THE POINT (X(I),BY,Z(K)). C C BD5 REAL ARRAY OF SIZE LDXBD BY NY (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE FRONT SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(5) VALUE STORED C ------------------------------ C 1 U C 2 DU/DZ C 3 NONE C C BD5(I,J) GIVES THE VALUE AT THE POINT (X(I),Y(J),BZ). C C BD6 REAL ARRAY OF SIYE LDXBD BY NY (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE BACK SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(6) VALUE STORED C ------------------------------ C 1 U C 2 DU/DZ C 3 NONE C C BD6(I,J) GIVES THE VALUE AT THE POINT (X(I),Y(J),AZ). C C LDXBD INTEGER SCALAR (INPUT) .GE. NX C THE LEADING DIMENSION OF THE ARRAYS BD2, BD4, BD5, AND C BD6, EXACTLY AS SPECIFIED IN THE CALLING PROGRAM. C C LDYBD INTEGER SCALAR (INPUT) .GE. NY C THE LEADING DIMENSION OF THE ARRAYS BD1 AND BD3, EXACTLY C AS SPECIFIED IN THE CALLING PROGRAM. C C IORDER INTEGER SCALAR (INPUT) C THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE C APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE C C 2 == SECOND ORDER ACCURATE 9-POINT COMPACT DIFFERENCES C 4 == FOURTH ORDER ACCURATE 9-POINT COMPACT DIFFERENCES C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ+2 (INPUT/OUTPUT) C ON INPUT, U(I,J,K) CONTAINS THE VALUE OF THE RIGHT HAND C SIDE OF THE PARTIAL DIFFERENTAIL EQUATION AT THE (I,J,K)TH C GRID POINT. THAT IS, C C U(I,J,K) = G(X(I),Y(J),Z(K)) C C FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ. C ON OUTPUT, U(I,J,K) IS THE VALUE OF THE COMPUTED SOLUTION C AT THE POINT (X(I),Y(J),Z(K)). THE PLANES U(NX+1,*,*), C U(NX+2,*,*), U(*,NY+1,*), U(*,NY+2,*), U(*,*,NZ+1), AND C U(*,*,NZ+2) ARE USED AS WORKING STORAGE. C C LDXU INTEGER SCALAR (INPUT) .GE. NX+2 C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C LDYU INTEGER SCALAR (INPUT) .GE. NY+2 C THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C WORK REAL ARRAY OF SIZE NWORK. C WORKING STORAGE REQUIRED BY HFFT3A. C C NWORK INTEGER SCALAR (INPUT) C .GE. MAX( (NX+1)*(NY+1)*(IORDER-2), C (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 ) C THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING C PROGRAM. THIS MAY BE REDUCED BY 4*NY IF COEFU.LE.0. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY C CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE C PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE C RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED. C THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT C SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN C ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN C ADDITIVE CONSTANT. C 1 == WARNING. COEFU.GT.0 A SOLUTION MAY NOT EXIST IF C COEFU IS AN EIGENVALUE OF THE LAPLACIAN. IF COEFU C IS NEAR ONE OF THESE VALUES THEN THE COMPUTED C SOLUTION MAY BE UNRELIABLE. C 0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION. C -1 == ERROR. NX.LT.4 C -2 == ERROR. NY.LT.4 C -3 == ERROR. NZ.LT.4 C -4 == ERROR. LDXU.LT.NX+2 C -5 == ERROR. LDYU.LT.NY+2 C -6 == ERROR. IORDER NOT 2 OR 4. C -7 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3. C -8 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON C ONE SIDE OF DOMAIN BUT NOT ON THE OPPOSITE. C -9 == ERROR. NWORK TOO SMALL. C -10 == ERROR. LDXGH.LT.NX+1 C -11 == ERROR. LDYGH.LT.NY+1 C C C C E X T E R N A L R E F E R E N C E S C ------------------------------------- C C FDIS3,HDIS3,FD3N,STORD3, C FD3D,FD2D,FD2DA,HD3N,REFL3, C MDALG3,MDALG2,EVDISC,TRISOL, C TRSALL,TRSOLG,TRSOLP, C SGPSL,FFTI,FFTB,FFTF -- THIS PACKAGE C C RFFTI,RFFTF,RFFTB, C SINTI,SINT,COSTI,COST, C SINQI,SINQF,SINQB, C COSQI,COSQF,COSQB -- FFTPACK (SEE REF. 2) C C R1MACH -- MACHINE CONSTANTS (SEE REF. 3) C C C P O R T A B I L I T Y C --------------------- C C THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977). C ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE C FUNCTION R1MACH (SEE REF. 3). C C C R E F E R E N C E S C ------------------- C C 1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD C FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS C II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS, C ORLANDO, FLA., 1984, 35-44. C C 2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE C PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS C ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3). C FFTPACK IS DESCRIBED IN C C P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL C COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, C PP. 51-83. C C FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE, C COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH, C BOX 3000, BOULDER, CO 80303, USA. C C 3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK C FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978), C PP. 177-188. C C 4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS, C HOLT, RINEHART AND WINSTON, NEW YORK, 1967. C C C A U T H O R / V E R S I O N C ----------------------------- C C RONALD F. BOISVERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C GAITHERSBURG, MD 20899 C USA C C ORIGINAL DECEMBER 1985 C REVISED APRIL 1987 C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, NZ, LDXGH, LDYGH, LDXBD, LDYBD, IORDER, * LDXU, LDYU, BCTY(6) REAL * H, COEFU, GH(LDXGH,LDYGH,*), U(LDXU,LDYU,*), * BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ), * BD5(LDXBD,NY), BD6(LDXBD,NY), WORK(NWORK) C C ... LOCAL VARIABLES C LOGICAL SNGULR, PRDX, PRDY, PRDZ INTEGER NXM1, NYM1, NZM1, NML REAL * A, B, C, D, FX, FY, FZ, FYZ, FACTOR, PERTRB, SCALE, UNORM C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 C SNGULR = (BCTY(RIGHT ) .NE. DRCH) .AND. * (BCTY(BOTTOM) .NE. DRCH) .AND. * (BCTY(LEFT ) .NE. DRCH) .AND. * (BCTY(TOP ) .NE. DRCH) .AND. * (BCTY(FRONT ) .NE. DRCH) .AND. * (BCTY(BACK ) .NE. DRCH) .AND. * (ABS(COEFU) .LT. R1MACH(4)) PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC PRDZ = BCTY(FRONT ) .EQ. PRDC C IL = 1 IR = NX JL = 1 JR = NY KL = 1 KR = NZ IF (BCTY(LEFT ) .EQ. DRCH) IL = 2 IF (BCTY(RIGHT ) .EQ. DRCH) IR = NXM1 IF (BCTY(BOTTOM) .EQ. DRCH) JL = 2 IF (BCTY(TOP ) .EQ. DRCH) JR = NYM1 IF (BCTY(BACK ) .EQ. DRCH) KL = 2 IF (BCTY(FRONT ) .EQ. DRCH) KR = NZM1 IF (PRDX) IR = NXM1 IF (PRDY) JR = NYM1 IF (PRDZ) KR = NZM1 NML = (IR-IL+1)*(JR-JL+1)*(KR-KL+1) C C C --------------------------- C CHECK VALIDITY OF ARGUMENTS C --------------------------- C INFO = 0 IF (NX .LT. PRDC) GO TO 901 IF (NY .LT. PRDC) GO TO 902 IF (NZ .LT. PRDC) GO TO 903 IF (LDXU .LT. NX+2) GO TO 904 IF (LDYU .LT. NY+2) GO TO 905 IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 906 DO 10 K=1,6 IF ((BCTY(K) .LT. DRCH) .OR. (BCTY(K) .GT. PRDC)) GO TO 907 10 CONTINUE IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT ) .NE. PRDC)) .OR. * ((BCTY(LEFT ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR. * ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP ) .NE. PRDC)) .OR. * ((BCTY(TOP ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) .OR. * ((BCTY(FRONT ) .EQ. PRDC) .AND. (BCTY(BACK ) .NE. PRDC)) .OR. * ((BCTY(BACK ) .EQ. PRDC) .AND. (BCTY(FRONT ) .NE. PRDC)) ) * GO TO 908 NEEDED = MAX( (NX+1)*(NY+1)*(IORDER-2), * (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 ) IF (NWORK .LT. NEEDED) GO TO 909 IF (LDXGH .LT. NX+1) GO TO 910 IF (LDYGH .LT. NY+1) GO TO 911 C IF (COEFU .GT. 0.0E0) INFO = 1 IF (SNGULR) INFO = 2 C C C ---------------------- C COMPUTE DISCRETIZATION C ---------------------- C IF (IORDER .EQ. 4) THEN CALL HDIS3(NX,NY,NZ,H,COEFU,GH,LDXGH-1,LDYGH-1,BCTY,BD1,BD2, * BD3,BD4,BD5,BD6,LDXBD,LDYBD,A,B,C,D,U,LDXU-1,LDYU-1, * WORK) ELSE CALL FDIS3(NX,NY,NZ,H,COEFU,BCTY,BD1,BD2,BD3,BD4,BD5,BD6, * LDXBD,LDYBD,A,B,C,D,U,LDXU,LDYU) ENDIF C C --------------------------------------- C ADJUST FOR CONSISTENCY IN SINGULAR CASE C --------------------------------------- C PERTRB = 0.0E0 IF (SNGULR) THEN SCALE = 0.0E0 DO 100 K=KL,KR FZ = 1.0E0 IF (.NOT.PRDZ.AND.(K.NE.1).AND.(K.NE.NZ)) FY = 2.0E0 DO 100 J=JL,JR FY = 1.0E0 IF (.NOT.PRDY.AND.(J.NE.1).AND.(J.NE.NY)) FY = 2.0E0 FYZ = FY*FZ DO 100 I=IL,IR FX = 1.0E0 IF (.NOT.PRDX.AND.(I.NE.1).AND.(I.NE.NX)) FX = 2.0E0 FACTOR = FX*FYZ PERTRB = PERTRB + FACTOR*U(I,J,K) SCALE = SCALE + FACTOR 100 CONTINUE PERTRB = -PERTRB/SCALE DO 110 K=KL,KR DO 110 J=JL,JR DO 110 I=IL,IR U(I,J,K) = U(I,J,K) + PERTRB 110 CONTINUE ENDIF C C C ------------------------------ C MATRIX DECOMPOSITION USING FFT C ------------------------------ C CALL MDALG3(A,B,C,D,BCTY,U,LDXU,LDYU,IL,IR,JL,JR,KL,KR,WORK) C C C ----------------------------------------- C SELECT MIN NORM SOLUTION IN SINGULAR CASE C ----------------------------------------- C IF (SNGULR) THEN UNORM = 0.0E0 DO 210 K=KL,KR DO 210 J=JL,JR DO 210 I=IL,IR UNORM = UNORM + U(I,J,K) 210 CONTINUE UNORM = UNORM/REAL(NML) DO 220 K=KL,KR DO 220 J=JL,JR DO 220 I=IL,IR U(I,J,K) = U(I,J,K) - UNORM 220 CONTINUE ENDIF C C C --------------------------------------- C COPY IDENTICAL PLANES IN PERIODIC CASES C --------------------------------------- C IF (PRDX) THEN DO 325 K=1,NZ DO 325 J=1,NY U(NX,J,K) = U(1,J,K) 325 CONTINUE ENDIF C IF (PRDY) THEN DO 375 K=1,NZ DO 375 I=1,NX U(I,NY,K) = U(I,1,K) 375 CONTINUE ENDIF C IF (PRDZ) THEN DO 425 J=1,NY DO 425 I=1,NX U(I,J,NZ) = U(I,J,1) 425 CONTINUE ENDIF C C C ----------- C NORMAL EXIT C ----------- C WORK(1) = PERTRB GO TO 999 C C C ----------- C ERROR EXITS C ----------- C 901 CONTINUE INFO = -1 GO TO 999 C 902 CONTINUE INFO = -2 GO TO 999 C 903 CONTINUE INFO = -3 GO TO 999 C 904 CONTINUE INFO = -4 GO TO 999 C 905 CONTINUE INFO = -5 GO TO 999 C 906 CONTINUE INFO = -6 GO TO 999 C 907 CONTINUE INFO = -7 GO TO 999 C 908 CONTINUE INFO = -8 GO TO 999 C 909 CONTINUE INFO = -9 GO TO 999 C 910 CONTINUE INFO = -10 GO TO 999 C 911 CONTINUE INFO = -11 GO TO 999 C 999 CONTINUE RETURN END SUBROUTINE FDIS3 (NX, NY, NZ, H, COEFU, BCTY, BD1, BD2, BD3, BD4, * BD5, BD6, LDXBD, LDYBD, A, B, C, D, U, * LDXU, LDYU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FDIS3 COMPUTES A SECOND ORDER FINITE DIFFERENCE DISCRETIZATION C FOR A THREE-DIMENSIONAL RECTANGULAR DOMAIN C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C H, COEFU REAL SCALARS (INPUT) C SEE HFFT3A. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C BD1, BD3 REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT) C SEE HFFT3A. C C BD2, BD4 REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT) C SEE HFFT3A. C C BD5, BD6 REAL ARRAYS OF SIZE LDXBD BY NY (INPUT) C SEE HFFT3A. C C LDXBD INTEGER SCALARS (INPUT) C LDYBD SEE HFFT3A. C C A,B,C,D REAL SCALARS (OUTPUT) C GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL C (SCALED TO O(1)) C C C C C B C C C C C C B C C B A B U = RIGHT SIDE C C B C C C C C C B C C C C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT) C ON INPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE PDE C EVALUATED AT THE (I,J,K)TH GRID POINT. C ON OUTPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE C DISCRETE PDE AT THE (I,J,K)TH GRID POINT. C C LDXU INTEGER SCALARS (INPUT) C LDYU SEE HFFT3A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), NX, NY, NZ, LDXU, LDYU REAL * BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ), * BD5(LDXBD,NY), BD6(LDXBD,NY), U(LDXU,LDYU,*), * COEFU, H, A, B, C, D C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY, PRDZ, HAVED, HAVEN INTEGER I, J, K, NXM1, NYM1, NZM1 REAL * BETA0, GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1 C COMMON /FD3COM/ GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 C HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR. * (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP ) .EQ. DRCH) .OR. * (BCTY(FRONT) .EQ. DRCH) .OR. (BCTY(BACK ) .EQ. DRCH) HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR. * (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP ) .EQ. NEUM) .OR. * (BCTY(FRONT) .EQ. NEUM) .OR. (BCTY(BACK ) .EQ. NEUM) PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC PRDZ = BCTY(FRONT ) .EQ. PRDC C H2 = H*H F = -H2*COEFU A = -(24.0E0 + 6.0E0*F) B = 2.0E0 C = 1.0E0 D = 0.0E0 BETA0 = 6.0E0*H2 GAMMA0 = -12.0E0*H GEDGE0 = -10.0E0*H GEDGE1 = -2.0E0*H GCORN0 = -8.0E0*H GCORN1 = -2.0E0*H C C C ---------------------------- C DISCRETIZE RIGHT SIDE OF PDE C ---------------------------- C ISTRT = 2 ISTOP = NXM1 IF (BCTY(LEFT ) .NE. DRCH) ISTRT = 1 IF (BCTY(RIGHT ) .EQ. NEUM) ISTOP = NX JSTRT = 2 JSTOP = NYM1 IF (BCTY(BOTTOM) .NE. DRCH) JSTRT = 1 IF (BCTY(TOP ) .EQ. NEUM) JSTOP = NY KSTRT = 2 KSTOP = NZM1 IF (BCTY(BACK ) .NE. DRCH) KSTRT = 1 IF (BCTY(FRONT ) .EQ. NEUM) KSTOP = NZ C DO 100 K=KSTRT,KSTOP DO 100 J=JSTRT,JSTOP DO 100 I=ISTRT,ISTOP U(I,J,K) = BETA0*U(I,J,K) 100 CONTINUE C C C --------------------------------------- C DISCRETIZE POINTS ON NEUMANN BOUNDARIES C --------------------------------------- C IF (HAVEN) CALL FD3N(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6, * LDXBD,LDYBD,U,LDXU,LDYU) C C ---------------------------------------------- C ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES C ---------------------------------------------- C IF (HAVED) THEN CALL STORD3(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD, * U,LDXU,LDYU) CALL FD3D(NX,NY,NZ,BCTY,B,C,D,U,LDXU,LDYU) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FD2DA (NX, NY, UD, LDXU, BCTY, A, B, C, U) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FD2DA ELIMINATES TERMS FROM EQUATIONS CORRESPONDING TO ALL POINTS C OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN ACCORDING TO A GIVEN C STENCIL. C C (THIS ROUTINE IS A UTILITY USED TO ELIMINATE AN ENTIRE DIRICHLET C PLANE IN THREE-DIMENSIONAL CALCULATIONS.) C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C UD REAL ARRAY OF SIZE LDXU BY NY (INPUT) C ALL ENTRIES CONTAIN VALUES OF THE FUNCTION TO BE C ELIMINATED. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY C AS DECLARED IN THE CALLING PROGRAM. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C A,B,C REAL SCALARS (INPUT) C FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE C ELIMINATION C C C B C C B A B C C B C C C U REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT) C ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE C SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND C SIDE OF A FINITE DIFFERENCE DISCRETIZATION. C ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT C THE GRID FUNCTION IN UD IS SUBTRACTED USING THE C GIVEN STENCIL. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY REAL * UD(LDXU,NY), U(LDXU,NY), A, B, C C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY INTEGER I, J, NXM1, NYM1 REAL * TWOB, TWOC C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 C PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C TWOB = 2.0E0*B TWOC = 2.0E0*C FORC = 4.0E0*C C C C ----------------------- C PROCESS INTERIOR POINTS C ----------------------- C DO 100 J=2,NYM1 DO 100 I=2,NXM1 U(I,J) = U(I,J) - (C*UD(I-1,J+1)+B*UD(I,J+1)+C*UD(I+1,J+1) * +B*UD(I-1,J )+A*UD(I,J )+B*UD(I+1,J ) * +C*UD(I-1,J-1)+B*UD(I,J-1)+C*UD(I+1,J-1)) 100 CONTINUE C C C ---------------------- C PROCESS NEUMANN POINTS C ---------------------- C C ... NEUMANN POINTS ON RIGHT EDGE C IF (BCTY(RIGHT) .EQ. NEUM) THEN DO 150 J=2,NYM1 U(NX,J) = U(NX,J) - (TWOC*UD(NXM1,J+1)+B*UD(NX,J+1) * +TWOB*UD(NXM1,J )+A*UD(NX,J ) * +TWOC*UD(NXM1,J-1)+B*UD(NX,J-1)) 150 CONTINUE ENDIF C C ... NEUMANN POINTS ON LEFT EDGE C IF (BCTY(LEFT) .EQ. NEUM) THEN DO 250 J=2,NYM1 U(1,J) = U(1,J) - (B*UD(1,J+1)+TWOC*UD(2,J+1) * +A*UD(1,J )+TWOB*UD(2,J ) * +B*UD(1,J-1)+TWOC*UD(2,J-1)) 250 CONTINUE ENDIF C C ... NEUMANN POINTS ON BOTTOM EDGE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN DO 350 I=2,NXM1 U(I,1) = U(I,1) - (TWOC*UD(I+1,2)+B*UD(I+1,1) * +TWOB*UD(I ,2)+A*UD(I ,1) * +TWOC*UD(I-1,2)+B*UD(I-1,1)) 350 CONTINUE ENDIF C C ... NEUMANN POINTS ON TOP EDGE C IF (BCTY(TOP) .EQ. NEUM) THEN DO 450 I=2,NXM1 U(I,NY) = U(I,NY) - (TWOC*UD(I+1,NYM1)+B*UD(I+1,NY) * +TWOB*UD(I ,NYM1)+A*UD(I ,NY) * +TWOC*UD(I-1,NYM1)+B*UD(I-1,NY)) 450 CONTINUE ENDIF C C ... BOTTOM RIGHT NEUMANN CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(NX,1) = U(NX,1) - (TWOB*UD(NX ,2)+ A*UD(NX ,1) * +FORC*UD(NXM1,2)+TWOB*UD(NXM1,1)) C C ... BOTTOM LEFT NEUMANN CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(1,1) = U(1,1) - (TWOB*UD(1,2)+ A*UD(1,1) * +FORC*UD(2,2)+TWOB*UD(2,1)) C C ... TOP RIGHT NEUMANN CORNER C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM)) * U(NX,NY) = U(NX,NY) - (TWOB*UD(NXM1,NY )+ A*UD(NX,NY ) * +FORC*UD(NXM1,NYM1)+TWOB*UD(NX,NYM1)) C C ... TOP LEFT NEUMANN CORNER C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM)) * U(1,NY) = U(1,NY) - (TWOB*UD(2,NY )+ A*UD(1,NY ) * +FORC*UD(2,NYM1)+TWOB*UD(1,NYM1)) C C C ----------------------- C PROCESS PERIODIC POINTS C ----------------------- C C ... LEFT PERIODIC EDGE C IF (PRDX) THEN DO 605 J=2,NYM1 U(1,J) = U(1,J) - (C*UD(NXM1,J+1)+B*UD(1,J+1)+C*UD(2,J+1) * +B*UD(NXM1,J )+A*UD(1,J )+B*UD(2,J ) * +C*UD(NXM1,J-1)+B*UD(1,J-1)+C*UD(2,J-1)) 605 CONTINUE ENDIF C C ... BOTTOM PERIODIC EDGE C IF (PRDY) THEN DO 615 I=2,NXM1 U(I,1) = U(I,1)-(C*UD(I-1,2 )+B*UD(I,2 )+C*UD(I+1,2 ) * +B*UD(I-1,1 )+A*UD(I,1 )+B*UD(I+1,1 ) * +C*UD(I-1,NYM1)+B*UD(I,NYM1)+C*UD(I+1,NYM1)) 615 CONTINUE ENDIF C C ... LEFT BOTTOM PERIODIC CORNER C IF (PRDX .AND. PRDY) * U(1,1) = U(1,1) - (C*UD(NXM1,2 )+B*UD(1,2 )+C*UD(2,2 ) * +B*UD(NXM1,1 )+A*UD(1,1 )+B*UD(2,1 ) * +C*UD(NXM1,NYM1)+B*UD(1,NYM1)+C*UD(2,NYM1)) C C ... LEFT BOTTOM PERIODIC/NEUMANN CORNER C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(1,1) = U(1,1) - (TWOC*UD(2 ,2)+B*UD(2 ,1) * +TWOB*UD(1 ,2)+A*UD(1 ,1) * +TWOC*UD(NXM1,2)+B*UD(NXM1,1)) C C ... LEFT BOTTOM NEUMANN/PERIODIC CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY) * U(1,1) = U(1,1) - (B*UD(1,2 )+TWOC*UD(2,2 ) * +A*UD(1,1 )+TWOB*UD(2,1 ) * +B*UD(1,NYM1)+TWOC*UD(2,NYM1)) C C ... LEFT TOP PERIODIC/NEUMANN CORNER C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) * U(1,NY) = U(1,NY) - (TWOC*UD(2 ,NYM1)+B*UD(2 ,NY) * +TWOB*UD(1 ,NYM1)+A*UD(1 ,NY) * +TWOC*UD(NXM1,NYM1)+B*UD(NXM1,NY)) C C ... RIGHT BOTTOM NEUMANN/PERIODIC CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY) * U(NX,1) = U(NX,1) - (TWOC*UD(NXM1,2 )+B*UD(NX,2 ) * +TWOB*UD(NXM1,1 )+A*UD(NX,1 ) * +TWOC*UD(NXM1,NYM1)+B*UD(NX,NYM1)) C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FD3D (NX, NY, NZ, BCTY, B, C, D, U, LDXU, LDYU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FD3D ELIMINATES KNOWN TERMS FROM EQUATIONS CORRESPONDING TO POINTS C NEAR DIRICHLET BOUNDARIES OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN. C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C UD REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT) C ENTRIES CORRESPONDING TO DIRICHLET POINTS CONTAIN C KNOWN VALUES OF THE SOLUTION. C C B,C,D REAL SCALARS (INPUT) C FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE C ELIMINATION C C D C D C C B C C D C D C C C B C C B * B C C B C C C D C D C C B C C D C D C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT) C ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE C SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND C SIDE OF A FINITE DIFFERENCE DISCRETIZATION. C ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT KNOWN C TERMS (DIRICHLET POINTS) ARE ELIMINATED FROM THE C LEFT HAND SIDE OF THE EQUATION. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY C AS DECLARED IN THE CALLING PROGRAM. C C LDYU INTEGER SCALAR (INPUT) C THE SECOND DIMENSION OF THE ARRAYS UD AND U EXACTLY C AS DECLARED IN THE CALLING PROGRAM. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), NX, NY, NZ REAL * U(LDXU,LDYU,NZ), B, C, D C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NZM1 = NZ - 1 NZM2 = NZ - 2 C TWOC = 2.0E0*C TWOD = 2.0E0*D C C ------------------------ C PROCESS EACH (X,Y) PLANE C ------------------------ C C ... BACK PLANE C IF (BCTY(BACK) .EQ. NEUM) THEN CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,B,C,U(1,1,1)) CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,TWOC,TWOD,U(1,1,1)) ENDIF IF (BCTY(BACK) .EQ. PRDC) THEN CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,C,D,U(1,1,1)) CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,B,C,U(1,1,1)) CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,C,D,U(1,1,1)) ENDIF C C ... INTERIOR PLANE NEAR BACK C IF (BCTY(BACK) .EQ. DRCH) * CALL FD2DA(NX,NY,U(1,1,1),LDXU,BCTY,B,C,D,U(1,1,2)) IF (BCTY(BACK) .NE. DRCH) * CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,C,D,U(1,1,2)) CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,B,C,U(1,1,2)) CALL FD2D(NX,NY,U(1,1,3),LDXU,BCTY,C,D,U(1,1,2)) C C ... INTERIOR PLANES C DO 100 K=3,NZM2 CALL FD2D(NX,NY,U(1,1,K-1),LDXU,BCTY,C,D,U(1,1,K)) CALL FD2D(NX,NY,U(1,1,K ),LDXU,BCTY,B,C,U(1,1,K)) CALL FD2D(NX,NY,U(1,1,K+1),LDXU,BCTY,C,D,U(1,1,K)) 100 CONTINUE C C ... INTERIOR PLANE NEAR FRONT C CALL FD2D(NX,NY,U(1,1,NZM2),LDXU,BCTY,C,D,U(1,1,NZM1)) CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,B,C,U(1,1,NZM1)) IF (BCTY(FRONT) .EQ. DRCH) * CALL FD2DA(NX,NY,U(1,1,NZ),LDXU,BCTY,B,C,D,U(1,1,NZM1)) IF (BCTY(FRONT) .EQ. NEUM) * CALL FD2D(NX,NY,U(1,1,NZ),LDXU,BCTY,C,D,U(1,1,NZM1)) IF (BCTY(FRONT) .EQ. PRDC) * CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,C,D,U(1,1,NZM1)) C C ... FRONT PLANE C IF (BCTY(FRONT) .EQ. NEUM) THEN CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,TWOC,TWOD,U(1,1,NZ)) CALL FD2D(NX,NY,U(1,1,NZ ),LDXU,BCTY,B,C,U(1,1,NZ)) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FD3N (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6, * LDXBD, LDYBD, U, LDXU, LDYU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FD3N COMPUTES THE SECOND ORDER FINITE DIFFERENCE DISCRETIZATION C AT ALL BOUNDARY POINTS OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN C WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED. C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C BD1, BD3 REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT) C SEE HFFT3A. C C BD2, BD4 REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT) C SEE HFFT3A. C C BD5, BD6 REAL ARRAYS OF SIZE LDXBD BY NY (INPUT) C SEE HFFT3A. C C LDXBD INTEGER SCALARS (INPUT) C LDYBD SEE HFFT3A. C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (OUTPUT) C ON EXIT, ENTRIES OF U CORRESPONDING TO NEUMANN BOUNDARY C POINTS CONTAIN THE RIGHT HAND SIDE OF THE SECOND ORDER C FINITE DIFFERENCE DISCRETIZATION C C LDXU INTEGER SCALARS (INPUT) C LDYU SEE HFFT3A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), NX, NY, NZ, LDXBD, LDYBD, LDXU, LDYU REAL * U(LDXU,LDYU,NZ), BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), * BD4(LDXBD,NZ), BD5(LDXBD,NY), BD6(LDXBD,NY) C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY, PRDZ INTEGER I, J, K, NXM1, NYM1, NZM1 REAL * GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1 C COMMON /FD3COM/ GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC PRDZ = BCTY(FRONT ) .EQ. PRDC C C C ------------------------------ C HANDLE POINTS ON NEUMANN SIDES C ------------------------------ C C ... RIGHT SIDE C IF (BCTY(RIGHT) .EQ. NEUM) THEN DO 205 K=2,NZM1 DO 205 J=2,NYM1 U(NX,J,K) = U(NX,J,K) + GAMMA0*BD1(J,K) 205 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .EQ. NEUM) THEN DO 215 K=2,NZM1 DO 215 J=2,NYM1 U(1,J,K) = U(1,J,K) - GAMMA0*BD3(J,K) 215 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .EQ. NEUM) THEN DO 225 K=2,NZM1 DO 225 I=2,NXM1 U(I,NY,K) = U(I,NY,K) + GAMMA0*BD4(I,K) 225 CONTINUE ENDIF C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN DO 235 K=2,NZM1 DO 235 I=2,NXM1 U(I,1,K) = U(I,1,K) - GAMMA0*BD2(I,K) 235 CONTINUE ENDIF C C ... FRONT SIDE C IF (BCTY(FRONT) .EQ. NEUM) THEN DO 245 J=2,NYM1 DO 245 I=2,NXM1 U(I,J,NZ) = U(I,J,NZ) + GAMMA0*BD5(I,J) 245 CONTINUE ENDIF C C ... BACK SIDE C IF (BCTY(BACK) .EQ. NEUM) THEN DO 255 J=2,NYM1 DO 255 I=2,NXM1 U(I,J,1) = U(I,J,1) - GAMMA0*BD6(I,J) 255 CONTINUE ENDIF C C C ------------------------------ C HANDLE POINTS ON NEUMANN EDGES C ------------------------------ C C ... RIGHT TOP EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 265 K=2,NZM1 U(NX,NY,K) = U(NX,NY,K) * + GEDGE0*( BD1(NY,K) + BD4(NX,K) ) * + GEDGE1*( BD1(NYM1,K) + BD4(NXM1,K) ) 265 CONTINUE ENDIF C C ... RIGHT BOTTOM EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN DO 275 K=2,NZM1 U(NX,1,K) = U(NX,1,K) * + GEDGE0*( BD1(1,K) - BD2(NX,K) ) * + GEDGE1*( BD1(2,K) - BD2(NXM1,K) ) 275 CONTINUE ENDIF C C ... LEFT TOP EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 285 K=2,NZM1 U(1,NY,K) = U(1,NY,K) * + GEDGE0*( -BD3(NY,K) + BD4(1,K) ) * + GEDGE1*( -BD3(NYM1,K) + BD4(2,K) ) 285 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN DO 295 K=2,NZM1 U(1,1,K) = U(1,1,K) * + GEDGE0*( -BD3(1,K) - BD2(1,K) ) * + GEDGE1*( -BD3(2,K) - BD2(2,K) ) 295 CONTINUE ENDIF C C ... RIGHT FRONT EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 305 J=2,NYM1 U(NX,J,NZ) = U(NX,J,NZ) * + GEDGE0*( BD1(J,NZ) + BD5(NX,J) ) * + GEDGE1*( BD1(J,NZM1) + BD5(NXM1,J) ) 305 CONTINUE ENDIF C C ... RIGHT BACK EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 315 J=2,NYM1 U(NX,J,1) = U(NX,J,1) * + GEDGE0*( BD1(J,1) - BD6(NX,J) ) * + GEDGE1*( BD1(J,2) - BD6(NXM1,J) ) 315 CONTINUE ENDIF C C ... LEFT FRONT EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 325 J=2,NYM1 U(1,J,NZ) = U(1,J,NZ) * + GEDGE0*( -BD3(J,NZ) + BD5(1,J) ) * + GEDGE1*( -BD3(J,NZM1) + BD5(2,J) ) 325 CONTINUE ENDIF C C ... LEFT BACK EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 335 J=2,NYM1 U(1,J,1) = U(1,J,1) * + GEDGE0*( -BD3(J,1) - BD6(1,J) ) * + GEDGE1*( -BD3(J,2) - BD6(2,J) ) 335 CONTINUE ENDIF C C ... TOP FRONT EDGE C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 345 I=2,NXM1 U(I,NY,NZ) = U(I,NY,NZ) * + GEDGE0*( BD4(I,NZ) + BD5(I,NY) ) * + GEDGE1*( BD4(I,NZM1) + BD5(I,NYM1) ) 345 CONTINUE ENDIF C C ... TOP BACK EDGE C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 355 I=2,NXM1 U(I,NY,1) = U(I,NY,1) * + GEDGE0*( BD4(I,1) - BD6(I,NY) ) * + GEDGE1*( BD4(I,2) - BD6(I,NYM1) ) 355 CONTINUE ENDIF C C ... BOTTOM FRONT EDGE C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 365 I=2,NXM1 U(I,1,NZ) = U(I,1,NZ) * + GEDGE0*( -BD2(I,NZ) + BD5(I,1) ) * + GEDGE1*( -BD2(I,NZM1) + BD5(I,2) ) 365 CONTINUE ENDIF C C ... BOTTOM BACK EDGE C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 375 I=2,NXM1 U(I,1,1) = U(I,1,1) * + GEDGE0*( -BD2(I,1) - BD6(I,1) ) * + GEDGE1*( -BD2(I,2) - BD6(I,2) ) 375 CONTINUE ENDIF C C C -------------------------------- C HANDLE POINTS AT NEUMANN CORNERS C -------------------------------- C C ... RIGHT TOP FRONT CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(NX,NY,NZ) = U(NX,NY,NZ) * + GCORN0*( BD1(NY,NZ)+BD4(NX,NZ)+BD5(NX,NY) ) * + GCORN1*( BD1(NYM1,NZ) + BD1(NY,NZM1) * + BD4(NXM1,NZ) + BD4(NX,NZM1) * + BD5(NXM1,NY) + BD5(NX,NYM1) ) C C ... LEFT TOP FRONT CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(1,NY,NZ) = U(1,NY,NZ) * + GCORN0*(-BD3(NY,NZ)+BD4(1,NZ)+BD5(1,NY) ) * + GCORN1*(-BD3(NYM1,NZ) - BD3(NY,NZM1) * + BD4(2,NZ) + BD4(1,NZM1) * + BD5(2,NY) + BD5(1,NYM1) ) C C ... RIGHT BOTTOM FRONT CORNER C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM)) * U(NX,1,NZ) = U(NX,1,NZ) * + GCORN0*( BD1(1,NZ)-BD2(NX,NZ)+BD5(NZ,1) ) * + GCORN1*( BD1(2,NZ) + BD1(1,NZM1) * - BD2(NXM1,NZ) - BD2(NX,NZM1) * + BD5(NXM1,1) + BD5(NX,2) ) C C ... LEFT BOTTOM FRONT CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM)) * U(1,1,NZ) = U(1,1,NZ) * + GCORN0*(-BD3(1,NZ)-BD2(1,NZ)+BD5(1,1) ) * + GCORN1*(-BD3(2,NZ) - BD3(1,NZM1) * - BD2(2,NZ) - BD2(1,NZM1) * + BD5(2,1) + BD5(1,2) ) C C ... RIGHT TOP BACK CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(NX,NY,1) = U(NX,NY,1) * + GCORN0*( BD1(NY,1)+BD4(NX,1)-BD6(NX,NY) ) * + GCORN1*( BD1(NYM1,1) + BD1(NY,2) * + BD4(NXM1,1) + BD4(NX,2) * - BD6(NXM1,NY) - BD6(NX,NYM1) ) C C ... LEFT TOP BACK CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(BACK) .EQ. NEUM)) * U(1,NY,1) = U(1,NY,1) * + GCORN0*(-BD3(NY,1)+BD4(1,1)-BD6(1,NY) ) * + GCORN1*(-BD3(NYM1,1) - BD3(NY,2) * + BD4(2,1) + BD4(1,2) * - BD6(2,NY) - BD6(1,NYM1) ) C C ... RIGHT BOTTOM BACK CORNER C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(NX,1,1) = U(NX,1,1) * + GCORN0*( BD1(1,1)-BD2(NX,1)-BD6(NX,1) ) * + GCORN1*( BD1(2,1) + BD1(1,2) * - BD2(NXM1,1) - BD2(NX,2) * - BD6(NXM1,1) - BD6(NX,2) ) C C ... LEFT BOTTOM BACK CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(1,1,1) = U(1,1,1) * + GCORN0*(-BD3(1,1)-BD2(1,1)-BD6(1,1) ) * + GCORN1*(-BD3(2,1) - BD3(1,2) * - BD2(2,1) - BD2(1,2) * - BD6(2,1) - BD6(1,2) ) C C IF (.NOT. (PRDX .OR. PRDY .OR. PRDZ)) GO TO 999 C C C --------------------------------------- C HANDLE POINTS AT NEUMANN/PERIODIC EDGES C --------------------------------------- C C ... BOTTOM BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN DO 405 I=2,NXM1 U(I,1,1) = U(I,1,1) - GAMMA0*BD2(I,1) 405 CONTINUE ENDIF C C ... BOTTOM BACK EDGE (PERIODIC/NEUMANN) C IF (PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 415 I=2,NXM1 U(I,1,1) = U(I,1,1) - GAMMA0*BD6(I,1) 415 CONTINUE ENDIF C C ... LEFT BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDZ) THEN DO 425 J=2,NYM1 U(1,J,1) = U(1,J,1) - GAMMA0*BD3(J,1) 425 CONTINUE ENDIF C C ... LEFT BACK EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 435 J=2,NYM1 U(1,J,1) = U(1,J,1) - GAMMA0*BD6(1,J) 435 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE (PERIODIC/NEUNANN) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN DO 445 K=2,NZM1 U(1,1,K) = U(1,1,K) - GAMMA0*BD2(1,K) 445 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY) THEN DO 455 K=2,NZM1 U(1,1,K) = U(1,1,K) - GAMMA0*BD3(1,K) 455 CONTINUE ENDIF C C ... LEFT TOP EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 465 K=2,NZM1 U(1,NY,K) = U(1,NY,K) + GAMMA0*BD4(1,K) 465 CONTINUE ENDIF C C ... LEFT FRONT EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 475 J=2,NYM1 U(1,J,NZ) = U(1,J,NZ) + GAMMA0*BD5(1,J) 475 CONTINUE ENDIF C C ... RIGHT BOTTOM EDGE (NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY) THEN DO 485 K=2,NZM1 U(NX,1,K) = U(NX,1,K) + GAMMA0*BD1(1,K) 485 CONTINUE ENDIF C C ... BOTTOM FRONT EDGE (PERIODIC/NEUMANN) C IF (PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 495 I=2,NXM1 U(I,1,NZ) = U(I,1,NZ) + GAMMA0*BD5(I,1) 495 CONTINUE ENDIF C C ... RIGHT BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDZ) THEN DO 505 J=2,NYM1 U(NX,J,1) = U(NX,J,1) + GAMMA0*BD1(J,1) 505 CONTINUE ENDIF C C ... TOP BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN DO 515 I=2,NXM1 U(I,NY,1) = U(I,NY,1) + GAMMA0*BD4(I,1) 515 CONTINUE ENDIF C C C ----------------------------------------- C HANDLE POINTS AT NEUMANN/PERIODIC CORNERS C ----------------------------------------- C C ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) * U(1,1,1) = U(1,1,1) - GAMMA0*BD3(1,1) C C ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/PERIODIC) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) * U(1,1,1) = U(1,1,1) - GAMMA0*BD2(1,1) C C ... LEFT BOTTOM BACK CORNER (PERIODIC/PERIODIC/NEUMANN) C IF (PRDX .AND. PRDY .AND. (BCTY(BACK) .EQ. NEUM)) * U(1,1,1) = U(1,1,1) - GAMMA0*BD6(1,1) C C ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD2(1,1) - BD6(1,1) ) * + GEDGE1*( -BD2(1,2) - BD6(1,2) ) C C ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(BACK) .EQ. NEUM)) * U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD3(1,1) - BD6(1,1) ) * + GEDGE1*( -BD3(1,2) - BD6(2,1) ) C C ... LEFT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) * U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD3(1,1) - BD2(1,1) ) * + GEDGE1*( -BD3(2,1) - BD2(2,1) ) C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) * U(NX,1,1) = U(NX,1,1) + GAMMA0*BD1(1,1) C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) * U(NX,1,1) = U(NX,1,1) * + GEDGE0*( BD1(1,1) - BD2(NX,1) ) * + GEDGE1*( BD1(2,1) - BD2(NXM1,1) ) C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(NX,1,1) = U(NX,1,1) * + GEDGE0*( BD1(1,1) - BD6(NX,1) ) * + GEDGE1*( BD1(1,2) - BD6(NXM1,1) ) C C ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/PERIODIC) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND. PRDZ) * U(1,NY,1) = U(1,NY,1) + GAMMA0*BD4(1,1) C C ... LEFT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ) * U(1,NY,1) = U(1,NY,1) * + GEDGE0*( -BD3(NY,1) + BD4(1,1) ) * + GEDGE1*( -BD3(NYM1,1) + BD4(2,1) ) C C ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(BACK) .EQ. NEUM)) * U(1,NY,1) = U(1,NY,1) * + GEDGE0*( BD4(1,1) - BD6(1,NY) ) * + GEDGE1*( BD4(1,2) - BD6(1,NYM1) ) C C ... LEFT BOTTOM FRONT CORNER (PERIODIC/PERIODIC/NEUMANN) C IF (PRDX .AND. PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) * U(1,1,NZ) = U(1,1,NZ) + GAMMA0*BD5(1,1) C C ... LEFT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(1,1,NZ) = U(1,1,NZ) * + GEDGE0*( -BD3(1,NZ) + BD5(1,1) ) * + GEDGE1*( -BD3(1,NZM1) + BD5(2,1) ) C C ... LEFT BOTTOM FRONT CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM)) * U(1,1,NZ) = U(1,1,NZ) * + GEDGE0*( -BD2(1,NZ) + BD5(1,1) ) * + GEDGE1*( -BD2(1,NZM1) + BD5(1,2) ) C C ... LEFT TOP FRONT CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(1,NY,NZ) = U(1,NY,NZ) * + GEDGE0*( BD4(1,NZ) + BD5(1,NY) ) * + GEDGE1*( BD4(1,NZM1) + BD5(1,NYM1) ) C C ... RIGHT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(NX,1,NZ) = U(NX,1,NZ) * + GEDGE0*( BD1(1,NZ) + BD5(NX,1) ) * + GEDGE1*( BD1(1,NZM1) + BD5(NXM1,1) ) C C ... RIGHT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ) * U(NX,NY,1) = U(NX,NY,1) * + GEDGE0*( BD1(NY,1) + BD4(NX,1) ) * + GEDGE1*( BD1(NYM1,1) + BD4(NXM1,1) ) C C C ---- C EXIT C ---- C 999 CONTINUE RETURN END SUBROUTINE HDIS3 (NX, NY, NZ, H, COEFU, GH, LMXGH, LMYGH, BCTY, * BD1, BD2, BD3, BD4, BD5, BD6, LDXBD, LDYBD, * A, B, C, D, U, LMXU, LMYU, WPLANE) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C HDIS3 COMPUTES A FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION C FOR A THREE-DIMENSIONAL RECTANGULAR DOMAIN C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C H, COEFU REAL SCALARS (INPUT) C SEE HFFT3A. C C GH REAL ARRAY OF SIZE LMXGH+1 BY LMYGH+1 BY NZ+1 (INPUT) C SEE HFFT3A. C C LMXGH INTEGER SCALAR (INPUT) C UPPER LIMIT OF FIRST DIMENSION OF ARRAY GH. MUST BE C LDXGH-1 (LDXGH IS DEFINED IN HFFT3A). C C LMYGH INTEGER SCALAR (INPUT) C UPPER LIMIT OF SECOND DIMENSION OF ARRAY GH. MUST BE C LDYGH-1 (LDYGH IS DEFINED IN HFFT3A). C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C BD1, BD3 REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT) C SEE HFFT3A. C C BD2, BD4 REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT) C SEE HFFT3A. C C BD5, BD6 REAL ARRAYS OF SIZE LDXBD BY NY (INPUT) C SEE HFFT3A. C C LDXBD INTEGER SCALARS (INPUT) C LDYBD SEE HFFT3A. C C C A,B,C,D REAL SCALARS (OUTPUT) C GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL C (SCALED TO O(1)) C C C C C B C C C C C C B C C B A B U = RIGHT SIDE C C B C C C C C C B C C C C C U REAL ARRAY OF SIZE LMXU+1 BY LMYU+1 BY NZ+2 C (INPUT/OUTPUT) C ON INPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE PDE C EVALUATED AT THE (I,J,K)TH GRID POINT. C ON OUTPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE C DISCRETE PDE AT THE (I,J,K)TH GRID POINT. C C LMXU INTEGER SCALAR (INPUT) C UPPER LIMIT OF FIRST DIMENSION OF ARRAY U. MUST BE C LDXU-1 (LDXU IS DEFINED IN HFFT3A). C C LMYU INTEGER SCALAR (INPUT) C UPPER LIMIT OF SECOND DIMENSION OF ARRAY U. MUST BE C LDYU-1 (LDYU IS DEFINED IN HFFT3A). C C WPLANE REAL ARRAY OF SIZE NX+1 BY 2 C WORKING STORAGE FOR HDIS3. C C C ****************************************************************** C * * C * NOTE -- THE ARRAYS U AND GH ARE INDEXED DIFFERENTLY IN * C * THIS ROUTINE: U(0:LMXU,0:LMYU,0:*) AND * C * GH(0:LMXGH,0:LMYGH,0:*) * C * * C ****************************************************************** C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), NX, NY, NZ, LMXGH, LMYGH, LDXBD, LDYBD, * LMXU, LMYU REAL * GH(0:LMXGH,0:LMYGH,0:*), U(0:LMXU,0:LMYU,0:*), BD1(LDYBD,NZ), * BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ), BD5(LDXBD,NY), * BD6(LDXBD,NY), WPLANE(0:NX,0:NY,0:1), * COEFU, H, A, B, C, D C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY, PRDZ, HELMHZ, HAVED, HAVEN INTEGER I, J, K, NXM1, NYM1, NZM1, LDXU, LDYU, P0, PM1 REAL * F, F2, H2, BETA0, BETA1, BETA2, GAMMA0, GAMMA1, * GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5, * GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5 C COMMON /HD3COM/ GAMMA0, GAMMA1, * GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5, * GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C H2 = H*H F = H2*COEFU F2 = F*F A = -24.0E0 + 5.0E0*F - F2/4.0E0 B = 2.0E0 - F/24.0E0 + F2/48.0E0 C = 1.0E0 + 5.0E0*F/48.0E0 D = 0.0E0 BETA0 = 2.0E0 - F/4.0E0 BETA1 = 0.50E0 BETA2 = F/48.0E0 GAMMA0 = -12.0E0 + 11.0E0*F/12.0E0 GAMMA1 = F/12.0E0 GEDGE0 = -23.0E0/3.0E0 + 125.0E0*F/144.0E0 GEDGE1 = -6.0E0 + F/4.0E0 GEDGE2 = 2.0E0 - F/48.0E0 GEDGE3 = -1.0E0/3.0E0 - F/72.0E0 GEDGE4 = -0.50E0 + F/48.0E0 GEDGE5 = 0.50E0 + F/16.0E0 GCORN0 = (-2328.0E0 + 245.0E0*F)/144.0E0 GCORN1 = ( 141.0E0 - 14.0E0*F)/18.0E0 GCORN2 = ( -24.0E0 - F)/72.0E0 GCORN3 = ( 840.0E0 - 103.0E0*F)/36.0E0 GCORN4 = (-1752.0E0 + 221.0E0*F)/144.0E0 GCORN5 = ( 57.0E0 - 7.0E0*F)/9.0E0 C BETA0 = H2*BETA0 BETA1 = H2*BETA1 BETA2 = H2*BETA2 GAMMA0 = H*GAMMA0 GAMMA1 = H*GAMMA1 GEDGE0 = H*GEDGE0 GEDGE1 = H*GEDGE1 GEDGE2 = H*GEDGE2 GEDGE3 = H*GEDGE3 GEDGE4 = H*GEDGE4 GEDGE5 = H*GEDGE5 GCORN0 = H*GCORN0 GCORN1 = H*GCORN1 GCORN2 = H*GCORN2 GCORN3 = H*GCORN3 GCORN4 = H*GCORN4 GCORN5 = H*GCORN5 C LDXU = LMXU + 1 LDYU = LMYU + 1 NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 C HELMHZ = COEFU .NE. 0.0E0 HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR. * (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP ) .EQ. DRCH) .OR. * (BCTY(FRONT) .EQ. DRCH) .OR. (BCTY(BACK ) .EQ. DRCH) HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR. * (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP ) .EQ. NEUM) .OR. * (BCTY(FRONT) .EQ. NEUM) .OR. (BCTY(BACK ) .EQ. NEUM) PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC PRDZ = BCTY(FRONT ) .EQ. PRDC C C C ----------------------------- C SHIFT VALUES OF G STORED IN U C ----------------------------- C DO 50 K=NZ,1,-1 DO 50 J=NY,1,-1 DO 50 I=NX,1,-1 U(I,J,K) = U(I-1,J-1,K-1) 50 CONTINUE C C C ----------------------------------------- C REFLECT FUNCTIONS G AND GH OUTSIDE DOMAIN C ----------------------------------------- C IF (HELMHZ) CALL REFL3(1,NX,NY,NZ,PRDX,PRDY,PRDZ,U,LMXU,LMYU) CALL REFL3(0,NXM1,NYM1,NZM1,PRDX,PRDY,PRDZ,GH,LMXGH,LMYGH) C C C ---------------------------- C DISCRETIZE RIGHT SIDE OF PDE C ---------------------------- C ISTRT = 2 ISTOP = NXM1 IF (BCTY(LEFT ) .NE. DRCH) ISTRT = 1 IF (BCTY(RIGHT ) .EQ. NEUM) ISTOP = NX JSTRT = 2 JSTOP = NYM1 IF (BCTY(BOTTOM) .NE. DRCH) JSTRT = 1 IF (BCTY(TOP ) .EQ. NEUM) JSTOP = NY KSTRT = 2 KSTOP = NZM1 IF (BCTY(BACK ) .NE. DRCH) KSTRT = 1 IF (BCTY(FRONT ) .EQ. NEUM) KSTOP = NZ C IF (HELMHZ) THEN C C CASE : HELMHOLTZ EQUATION C P0 = 0 DO 60 J=0,NY DO 60 I=0,NX WPLANE(I,J,P0) = U(I,J,KSTRT-1) 60 CONTINUE DO 100 K=KSTRT,KSTOP PM1 = P0 P0 = 1 - PM1 DO 70 J=0,NY DO 70 I=0,NX WPLANE(I,J,P0) = U(I,J,K) 70 CONTINUE DO 100 J=JSTRT,JSTOP DO 100 I=ISTRT,ISTOP C U(I,J,K) = BETA0*U(I,J,K) * + BETA1*( GH(I,J,K) + GH(I-1,J,K) + * GH(I,J-1,K) + GH(I-1,J,K-1) + * GH(I,J,K-1) + GH(I-1,J-1,K) + * GH(I,J-1,K-1) + GH(I-1,J-1,K-1) ) * + BETA2*( U(I+1,J,K) + WPLANE(I-1,J,P0) + * U(I,J+1,K) + WPLANE(I,J-1,P0) + * U(I,J,K+1) + WPLANE(I,J,PM1) ) 100 CONTINUE C ELSE C C CASE : POISSON EQUATION C DO 200 K=KSTRT,KSTOP DO 200 J=JSTRT,JSTOP DO 200 I=ISTRT,ISTOP C U(I,J,K) = BETA0*U(I,J,K) * + BETA1*( GH(I,J,K) + GH(I-1,J,K) + * GH(I,J-1,K) + GH(I-1,J,K-1) + * GH(I,J,K-1) + GH(I-1,J-1,K) + * GH(I,J-1,K-1) + GH(I-1,J-1,K-1) ) 200 CONTINUE C ENDIF C C C ------------------------- C REMOVE SHIFT FROM ARRAY U C ------------------------- C DO 250 K=0,NZM1 DO 250 J=0,NYM1 DO 250 I=0,NXM1 U(I,J,K) = U(I+1,J+1,K+1) 250 CONTINUE C C C ----------------------------------- C HANDLE POINTS ON NEUMANN BOUNDARIES C ----------------------------------- C IF (HAVEN) * CALL HD3N(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD, * U,LDXU,LDYU) C C C ---------------------------------------------- C ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES C ---------------------------------------------- C IF (HAVED) THEN CALL STORD3(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD, * U,LDXU,LDYU) CALL FD3D(NX,NY,NZ,BCTY,B,C,D,U,LDXU,LDYU) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE HD3N (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6, * LDXBD, LDYBD, U, LDXU, LDYU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C HD3N COMPUTES THE FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION C AT ALL BOUNDARY POINTS OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN C WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED. C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C BD1, BD3 REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT) C SEE HFFT3A. C C BD2, BD4 REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT) C SEE HFFT3A. C C BD5, BD6 REAL ARRAYS OF SIZE LDXBD BY NY (INPUT) C SEE HFFT3A. C C LDXBD INTEGER SCALARS (INPUT) C LDYBD SEE HFFT3A. C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (OUTPUT) C ON EXIT, ENTRIES CORRESPONDING TO NEUMANN BOUNDARY C POINTS CONTAIN THE RIGHT HAND SIDE OF THE FINITE C DIFFERENCE DISCRETIZTION C C LDXU INTEGER SCALARS (INPUT) C LDYU SEE HFFT3A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), NX, NY, NZ, LDXBD, LDYBD, LDXU, LDYU REAL * U(LDXU,LDYU,NZ), BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), * BD4(LDXBD,NZ), BD5(LDXBD,NY), BD6(LDXBD,NY) C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY, PRDZ INTEGER I, J, K, NXM1, NYM1, NZM1, NXM2, NYM2, NZM2, * NXM3, NYM3, NZM3 REAL * GAMMA0, GAMMA1, * GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5, * GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5 C COMMON /HD3COM/ GAMMA0, GAMMA1, * GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5, * GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NZM1 = NZ - 1 NXM2 = NX - 2 NYM2 = NY - 2 NZM2 = NZ - 2 NXM3 = NX - 3 NYM3 = NY - 3 NZM3 = NZ - 3 PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC PRDZ = BCTY(FRONT ) .EQ. PRDC C C C ------------------------------ C HANDLE POINTS ON NEUMANN SIDES C ------------------------------ C C ... RIGHT SIDE C IF (BCTY(RIGHT) .EQ. NEUM) THEN DO 205 K=2,NZM1 DO 205 J=2,NYM1 U(NX,J,K) = U(NX,J,K) * + GAMMA0*BD1(J,K) * + GAMMA1*(BD1(J+1,K) + BD1(J-1,K) + * BD1(J,K+1) + BD1(J,K-1) ) 205 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .EQ. NEUM) THEN DO 215 K=2,NZM1 DO 215 J=2,NYM1 U(1,J,K) = U(1,J,K) * - GAMMA0*BD3(J,K) * - GAMMA1*(BD3(J+1,K) + BD3(J-1,K) + * BD3(J,K+1) + BD3(J,K-1) ) 215 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .EQ. NEUM) THEN DO 225 K=2,NZM1 DO 225 I=2,NXM1 U(I,NY,K) = U(I,NY,K) * + GAMMA0*BD4(I,K) * + GAMMA1*(BD4(I+1,K) + BD4(I-1,K) + * BD4(I,K+1) + BD4(I,K-1) ) 225 CONTINUE ENDIF C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN DO 235 K=2,NZM1 DO 235 I=2,NXM1 U(I,1,K) = U(I,1,K) * - GAMMA0*BD2(I,K) * - GAMMA1*(BD2(I+1,K) + BD2(I-1,K) + * BD2(I,K+1) + BD2(I,K-1) ) 235 CONTINUE ENDIF C C ... FRONT SIDE C IF (BCTY(FRONT) .EQ. NEUM) THEN DO 245 J=2,NYM1 DO 245 I=2,NXM1 U(I,J,NZ) = U(I,J,NZ) * + GAMMA0*BD5(I,J) * + GAMMA1*(BD5(I+1,J) + BD5(I-1,J) + * BD5(I,J+1) + BD5(I,J-1) ) 245 CONTINUE ENDIF C C ... BACK SIDE C IF (BCTY(BACK) .EQ. NEUM) THEN DO 255 J=2,NYM1 DO 255 I=2,NXM1 U(I,J,1) = U(I,J,1) * - GAMMA0*BD6(I,J) * - GAMMA1*(BD6(I+1,J) + BD6(I-1,J) + * BD6(I,J+1) + BD6(I,J-1) ) 255 CONTINUE ENDIF C C C ------------------------------ C HANDLE POINTS ON NEUMANN EDGES C ------------------------------ C C ... RIGHT TOP EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 265 K=2,NZM1 U(NX,NY,K) = U(NX,NY,K) * + GEDGE0*( BD1(NY,K) + BD4(NX,K) ) * + GEDGE1*( BD1(NYM1,K) + BD4(NXM1,K) ) * + GEDGE2*( BD1(NYM2,K) + BD4(NXM2,K) ) * + GEDGE3*( BD1(NYM3,K) + BD4(NXM3,K) ) * + GEDGE4*( BD1(NY,K+1) + BD4(NX,K+1) * + BD1(NY,K-1) + BD4(NX,K-1) ) * + GEDGE5*( BD1(NYM1,K+1) + BD4(NXM1,K+1) * + BD1(NYM1,K-1) + BD4(NXM1,K-1) ) 265 CONTINUE ENDIF C C ... RIGHT BOTTOM EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN DO 275 K=2,NZM1 U(NX,1,K) = U(NX,1,K) * + GEDGE0*( BD1(1,K) - BD2(NX,K) ) * + GEDGE1*( BD1(2,K) - BD2(NXM1,K) ) * + GEDGE2*( BD1(3,K) - BD2(NXM2,K) ) * + GEDGE3*( BD1(4,K) - BD2(NXM3,K) ) * + GEDGE4*( BD1(1,K+1) - BD2(NX,K+1) * + BD1(1,K-1) - BD2(NX,K-1) ) * + GEDGE5*( BD1(2,K+1) - BD2(NXM1,K+1) * + BD1(2,K-1) - BD2(NXM1,K-1) ) 275 CONTINUE ENDIF C C ... LEFT TOP EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 285 K=2,NZM1 U(1,NY,K) = U(1,NY,K) * + GEDGE0*( -BD3(NY,K) + BD4(1,K) ) * + GEDGE1*( -BD3(NYM1,K) + BD4(2,K) ) * + GEDGE2*( -BD3(NYM2,K) + BD4(3,K) ) * + GEDGE3*( -BD3(NYM3,K) + BD4(4,K) ) * + GEDGE4*( -BD3(NY,K+1) + BD4(1,K+1) * -BD3(NY,K-1) + BD4(1,K-1) ) * + GEDGE5*( -BD3(NYM1,K+1) + BD4(2,K+1) * -BD3(NYM1,K-1) + BD4(2,K-1) ) 285 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN DO 295 K=2,NZM1 U(1,1,K) = U(1,1,K) * + GEDGE0*( -BD3(1,K) - BD2(1,K) ) * + GEDGE1*( -BD3(2,K) - BD2(2,K) ) * + GEDGE2*( -BD3(3,K) - BD2(3,K) ) * + GEDGE3*( -BD3(4,K) - BD2(4,K) ) * + GEDGE4*( -BD3(1,K+1) - BD2(1,K+1) * -BD3(1,K-1) - BD2(1,K-1) ) * + GEDGE5*( -BD3(2,K+1) - BD2(2,K+1) * -BD3(2,K-1) - BD2(2,K-1) ) 295 CONTINUE ENDIF C C ... RIGHT FRONT EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 305 J=2,NYM1 U(NX,J,NZ) = U(NX,J,NZ) * + GEDGE0*( BD1(J,NZ) + BD5(NX,J) ) * + GEDGE1*( BD1(J,NZM1) + BD5(NXM1,J) ) * + GEDGE2*( BD1(J,NZM2) + BD5(NXM2,J) ) * + GEDGE3*( BD1(J,NZM3) + BD5(NXM3,J) ) * + GEDGE4*( BD1(J+1,NZ) + BD5(NX,J+1) * + BD1(J-1,NZ) + BD5(NX,J-1) ) * + GEDGE5*( BD1(J+1,NZM1) + BD5(NXM1,J+1) * + BD1(J-1,NZM1) + BD5(NXM1,J-1) ) 305 CONTINUE ENDIF C C ... RIGHT BACK EDGE C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 315 J=2,NYM1 U(NX,J,1) = U(NX,J,1) * + GEDGE0*( BD1(J,1) - BD6(NX,J) ) * + GEDGE1*( BD1(J,2) - BD6(NXM1,J) ) * + GEDGE2*( BD1(J,3) - BD6(NXM2,J) ) * + GEDGE3*( BD1(J,4) - BD6(NXM3,J) ) * + GEDGE4*( BD1(J+1,1) - BD6(NX,J+1) * + BD1(J-1,1) - BD6(NX,J-1) ) * + GEDGE5*( BD1(J+1,2) - BD6(NXM1,J+1) * + BD1(J-1,2) - BD6(NXM1,J-1) ) 315 CONTINUE ENDIF C C ... LEFT FRONT EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 325 J=2,NYM1 U(1,J,NZ) = U(1,J,NZ) * + GEDGE0*( -BD3(J,NZ) + BD5(1,J) ) * + GEDGE1*( -BD3(J,NZM1) + BD5(2,J) ) * + GEDGE2*( -BD3(J,NZM2) + BD5(3,J) ) * + GEDGE3*( -BD3(J,NZM3) + BD5(4,J) ) * + GEDGE4*( -BD3(J+1,NZ) + BD5(1,J+1) * -BD3(J-1,NZ) + BD5(1,J-1) ) * + GEDGE5*( -BD3(J+1,NZM1) + BD5(2,J+1) * -BD3(J-1,NZM1) + BD5(2,J-1) ) 325 CONTINUE ENDIF C C ... LEFT FRON EDGE C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 335 J=2,NYM1 U(1,J,1) = U(1,J,1) * + GEDGE0*( -BD3(J,1) - BD6(1,J) ) * + GEDGE1*( -BD3(J,2) - BD6(2,J) ) * + GEDGE2*( -BD3(J,3) - BD6(3,J) ) * + GEDGE3*( -BD3(J,4) - BD6(4,J) ) * + GEDGE4*( -BD3(J+1,1) - BD6(1,J+1) * -BD3(J-1,1) - BD6(1,J-1) ) * + GEDGE5*( -BD3(J+1,2) - BD6(2,J+1) * -BD3(J-1,2) - BD6(2,J-1) ) 335 CONTINUE ENDIF C C ... TOP FRONT EDGE C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 345 I=2,NXM1 U(I,NY,NZ) = U(I,NY,NZ) * + GEDGE0*( BD4(I,NZ) + BD5(I,NY) ) * + GEDGE1*( BD4(I,NZM1) + BD5(I,NYM1) ) * + GEDGE2*( BD4(I,NZM2) + BD5(I,NYM2) ) * + GEDGE3*( BD4(I,NZM3) + BD5(I,NYM3) ) * + GEDGE4*( BD4(I+1,NZ) + BD5(I+1,NY) * + BD4(I-1,NZ) + BD5(I-1,NY) ) * + GEDGE5*( BD4(I+1,NZM1) + BD5(I+1,NYM1) * + BD4(I-1,NZM1) + BD5(I-1,NYM1) ) 345 CONTINUE ENDIF C C ... TOP BACK EDGE C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 355 I=2,NXM1 U(I,NY,1) = U(I,NY,1) * + GEDGE0*( BD4(I,1) - BD6(I,NY) ) * + GEDGE1*( BD4(I,2) - BD6(I,NYM1) ) * + GEDGE2*( BD4(I,3) - BD6(I,NYM2) ) * + GEDGE3*( BD4(I,4) - BD6(I,NYM3) ) * + GEDGE4*( BD4(I+1,1) - BD6(I+1,NY) * + BD4(I-1,1) - BD6(I-1,NY) ) * + GEDGE5*( BD4(I+1,2) - BD6(I+1,NYM1) * + BD4(I-1,2) - BD6(I-1,NYM1) ) 355 CONTINUE ENDIF C C ... BOTTOM FRONT EDGE C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 365 I=2,NXM1 U(I,1,NZ) = U(I,1,NZ) * + GEDGE0*( -BD2(I,NZ) + BD5(I,1) ) * + GEDGE1*( -BD2(I,NZM1) + BD5(I,2) ) * + GEDGE2*( -BD2(I,NZM2) + BD5(I,3) ) * + GEDGE3*( -BD2(I,NZM3) + BD5(I,4) ) * + GEDGE4*( -BD2(I+1,NZ) + BD5(I+1,1) * -BD2(I-1,NZ) + BD5(I-1,1) ) * + GEDGE5*( -BD2(I+1,NZM1) + BD5(I+1,2) * -BD2(I-1,NZM1) + BD5(I-1,2) ) 365 CONTINUE ENDIF C C ... BOTTOM BACK EDGE C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 375 I=2,NXM1 U(I,1,1) = U(I,1,1) * + GEDGE0*( -BD2(I,1) - BD6(I,1) ) * + GEDGE1*( -BD2(I,2) - BD6(I,2) ) * + GEDGE2*( -BD2(I,3) - BD6(I,3) ) * + GEDGE3*( -BD2(I,4) - BD6(I,4) ) * + GEDGE4*( -BD2(I+1,1) - BD6(I+1,1) * -BD2(I-1,1) - BD6(I-1,1) ) * + GEDGE5*( -BD2(I+1,2) - BD6(I+1,2) * -BD2(I-1,2) - BD6(I-1,2) ) 375 CONTINUE ENDIF C C C -------------------------------- C HANDLE POINTS AT NEUMANN CORNERS C -------------------------------- C C ... RIGHT TOP FRONT CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(NX,NY,NZ) = U(NX,NY,NZ) * + GCORN0*( BD1(NYM1,NZ) + BD1(NY,NZM1) * + BD4(NXM1,NZ) + BD4(NX,NZM1) * + BD5(NXM1,NY) + BD5(NX,NYM1) ) * + GCORN1*( BD1(NYM2,NZ) + BD1(NY,NZM2) * + BD4(NXM2,NZ) + BD4(NX,NZM2) * + BD5(NXM2,NY) + BD5(NX,NYM2) ) * + GCORN2*( BD1(NYM3,NZ) + BD1(NY,NZM3) * + BD4(NXM3,NZ) + BD4(NX,NZM3) * + BD5(NXM3,NY) + BD5(NX,NYM3) ) * + GCORN3*( BD1(NYM1,NZM1)+BD4(NXM1,NZM1)+BD5(NXM1,NYM1)) * + GCORN4*( BD1(NYM1,NZM2) + BD1(NYM2,NZM1) * + BD4(NXM1,NZM2) + BD4(NXM2,NZM1) * + BD5(NXM1,NYM2) + BD5(NXM2,NYM1) ) * + GCORN5*( BD1(NYM2,NZM2)+BD4(NXM2,NZM2)+BD5(NXM2,NYM2)) C C ... LEFT TOP FRONT CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM)) * U(1,NY,NZ) = U(1,NY,NZ) * + GCORN0*(-BD3(NYM1,NZ) - BD3(NY,NZM1) * + BD4(2,NZ) + BD4(1,NZM1) * + BD5(2,NY) + BD5(1,NYM1) ) * + GCORN1*(-BD3(NYM2,NZ) - BD3(NY,NZM2) * + BD4(3,NZ) + BD4(1,NZM2) * + BD5(3,NY) + BD5(1,NYM2) ) * + GCORN2*(-BD3(NYM3,NZ) - BD3(NY,NZM3) * + BD4(4,NZ) + BD4(1,NZM3) * + BD5(4,NY) + BD5(1,NYM3) ) * + GCORN3*(-BD3(NYM1,NZM1)+BD4(2,NZM1)+BD5(2,NYM1)) * + GCORN4*(-BD3(NYM1,NZM2) - BD3(NYM2,NZM1) * + BD4(2,NZM2) + BD4(3,NZM1) * + BD5(2,NYM2) + BD5(3,NYM1) ) * + GCORN5*(-BD3(NYM2,NZM2)+BD4(3,NZM2)+BD5(3,NYM2)) C C ... RIGHT BOTTOM FRONT CORNER C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM)) * U(NX,1,NZ) = U(NX,1,NZ) * + GCORN0*( BD1(2,NZ) + BD1(1,NZM1) * - BD2(NXM1,NZ) - BD2(NX,NZM1) * + BD5(NXM1,1) + BD5(NX,2) ) * + GCORN1*( BD1(3,NZ) + BD1(1,NZM2) * - BD2(NXM2,NZ) - BD2(NX,NZM2) * + BD5(NXM2,1) + BD5(NX,3) ) * + GCORN2*( BD1(4,NZ) + BD1(1,NZM3) * - BD2(NXM3,NZ) - BD2(NX,NZM3) * + BD5(NXM3,1) + BD5(NX,4) ) * + GCORN3*( BD1(2,NZM1)-BD2(NXM1,NZM1)+BD5(NXM1,2)) * + GCORN4*( BD1(2,NZM2) + BD1(3,NZM1) * - BD2(NXM1,NZM2) - BD2(NXM2,NZM1) * + BD5(NXM1,3) + BD5(NXM2,2) ) * + GCORN5*( BD1(3,NZM2)-BD2(NXM2,NZM2)+BD5(NXM2,3)) C C ... LEFT BOTTOM FRONT CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM)) * U(1,1,NZ) = U(1,1,NZ) * + GCORN0*(-BD3(2,NZ) - BD3(1,NZM1) * - BD2(2,NZ) - BD2(1,NZM1) * + BD5(2,1) + BD5(1,2) ) * + GCORN1*(-BD3(3,NZ) - BD3(1,NZM2) * - BD2(3,NZ) - BD2(1,NZM2) * + BD5(3,1) + BD5(1,3) ) * + GCORN2*(-BD3(4,NZ) - BD3(1,NZM3) * - BD2(4,NZ) - BD2(1,NZM3) * + BD5(4,1) + BD5(1,4) ) * + GCORN3*(-BD3(2,NZM1)-BD2(2,NZM1)+BD5(2,2)) * + GCORN4*(-BD3(2,NZM2) - BD3(3,NZM1) * - BD2(2,NZM2) - BD2(3,NZM1) * + BD5(2,3) + BD5(3,2) ) * + GCORN5*(-BD3(3,NZM2)-BD2(3,NZM2)+BD5(3,3)) C C ... RIGHT TOP BACK CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(NX,NY,1) = U(NX,NY,1) * + GCORN0*( BD1(NYM1,1) + BD1(NY,2) * + BD4(NXM1,1) + BD4(NX,2) * - BD6(NXM1,NY) - BD6(NX,NYM1) ) * + GCORN1*( BD1(NYM2,1) + BD1(NY,3) * + BD4(NXM2,1) + BD4(NX,3) * - BD6(NXM2,NY) - BD6(NX,NYM2) ) * + GCORN2*( BD1(NYM3,1) + BD1(NY,4) * + BD4(NXM3,1) + BD4(NX,4) * - BD6(NXM3,NY) - BD6(NX,NYM3) ) * + GCORN3*( BD1(NYM1,2)+BD4(NXM1,2)-BD6(NXM1,NYM1)) * + GCORN4*( BD1(NYM1,3) + BD1(NYM2,2) * + BD4(NXM1,3) + BD4(NXM2,2) * - BD6(NXM1,NYM2) - BD6(NXM2,NYM1) ) * + GCORN5*( BD1(NYM2,3)+BD4(NXM2,3)-BD6(NXM2,NYM2)) C C ... LEFT TOP BACK CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(BACK) .EQ. NEUM)) * U(1,NY,1) = U(1,NY,1) * + GCORN0*(-BD3(NYM1,1) - BD3(NY,2) * + BD4(2,1) + BD4(1,2) * - BD6(2,NY) - BD6(1,NYM1) ) * + GCORN1*(-BD3(NYM2,1) - BD3(NY,3) * + BD4(3,1) + BD4(1,3) * - BD6(3,NY) - BD6(1,NYM2) ) * + GCORN2*(-BD3(NYM3,1) - BD3(NY,4) * + BD4(4,1) + BD4(1,4) * - BD6(4,NY) - BD6(1,NYM3) ) * + GCORN3*(-BD3(NYM1,2)+BD4(2,2)-BD6(2,NYM1)) * + GCORN4*(-BD3(NYM1,3) - BD3(NYM2,2) * + BD4(2,3) + BD4(3,2) * - BD6(2,NYM2) - BD6(3,NYM1) ) * + GCORN5*(-BD3(NYM2,3)+BD4(3,3)-BD6(3,NYM2)) C C ... RIGHT BOTTOM BACK CORNER C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(NX,1,1) = U(NX,1,1) * + GCORN0*( BD1(2,1) + BD1(1,2) * - BD2(NXM1,1) - BD2(NX,2) * - BD6(NXM1,1) - BD6(NX,2) ) * + GCORN1*( BD1(3,1) + BD1(1,3) * - BD2(NXM2,1) - BD2(NX,3) * - BD6(NXM2,1) - BD6(NX,3) ) * + GCORN2*( BD1(4,1) + BD1(1,4) * - BD2(NXM3,1) - BD2(NX,4) * - BD6(NXM3,1) - BD6(NX,4) ) * + GCORN3*( BD1(2,2)-BD2(NXM1,2)-BD6(NXM1,2)) * + GCORN4*( BD1(2,3) + BD1(3,2) * - BD2(NXM1,3) - BD2(NXM2,2) * - BD6(NXM1,3) - BD6(NXM2,2) ) * + GCORN5*( BD1(3,3)-BD2(NXM2,3)-BD6(NXM2,3)) C C ... LEFT BOTTOM BACK CORNER C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK ) .EQ. NEUM)) * U(1,1,1) = U(1,1,1) * + GCORN0*(-BD3(2,1) - BD3(1,2) * - BD2(2,1) - BD2(1,2) * - BD6(2,1) - BD6(1,2) ) * + GCORN1*(-BD3(3,1) - BD3(1,3) * - BD2(3,1) - BD2(1,3) * - BD6(3,1) - BD6(1,3) ) * + GCORN2*(-BD3(4,1) - BD3(1,4) * - BD2(4,1) - BD2(1,4) * - BD6(4,1) - BD6(1,4) ) * + GCORN3*(-BD3(2,2)-BD2(2,2)-BD6(2,2)) * + GCORN4*(-BD3(2,3) - BD3(3,2) * - BD2(2,3) - BD2(3,2) * - BD6(2,3) - BD6(3,2) ) * + GCORN5*(-BD3(3,3)-BD2(3,3)-BD6(3,3)) C C IF (.NOT. (PRDX .OR. PRDY .OR. PRDZ)) GO TO 999 C C C --------------------------------------- C HANDLE POINTS ON NEUMANN/PERIODIC EDGES C --------------------------------------- C C ... BOTTOM BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN DO 405 I=2,NXM1 U(I,1,1) = U(I,1,1) * - GAMMA0*BD2(I,1) * - GAMMA1*(BD2(I+1,1) + BD2(I-1,1) + * BD2(I,2) + BD2(I,NZM1) ) 405 CONTINUE ENDIF C C ... BOTTOM BACK EDGE (PERIODIC/NEUMANN) C IF (PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 415 I=2,NXM1 U(I,1,1) = U(I,1,1) * - GAMMA0*BD6(I,1) * - GAMMA1*(BD6(I+1,1) + BD6(I-1,1) + * BD6(I,2) + BD6(I,NYM1) ) 415 CONTINUE ENDIF C C ... LEFT BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDZ) THEN DO 425 J=2,NYM1 U(1,J,1) = U(1,J,1) * - GAMMA0*BD3(J,1) * - GAMMA1*(BD3(J+1,1) + BD3(J-1,1) + * BD3(J,2) + BD3(J,NZM1) ) 425 CONTINUE ENDIF C C ... LEFT BACK EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(BACK) .EQ. NEUM)) THEN DO 435 J=2,NYM1 U(1,J,1) = U(1,J,1) * - GAMMA0*BD6(1,J) * - GAMMA1*(BD6(2,J) + BD6(NXM1,J) + * BD6(1,J+1) + BD6(1,J-1) ) 435 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC) C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDX) THEN DO 445 K=2,NZM1 U(1,1,K) = U(1,1,K) * - GAMMA0*BD2(1,K) * - GAMMA1*(BD2(2,K) + BD2(NXM1,K) + * BD2(1,K+1) + BD2(1,K-1) ) 445 CONTINUE ENDIF C C ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY) THEN DO 455 K=2,NZM1 U(1,1,K) = U(1,1,K) * - GAMMA0*BD3(1,K) * - GAMMA1*(BD3(2,K) + BD3(NYM1,K) + * BD3(1,K+1) + BD3(1,K-1) ) 455 CONTINUE ENDIF C C ... LEFT TOP EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) THEN DO 465 K=2,NZM1 U(1,NY,K) = U(1,NY,K) * + GAMMA0*BD4(1,K) * + GAMMA1*(BD4(2,K) + BD4(NXM1,K) + * BD4(1,K+1) + BD4(1,K-1) ) 465 CONTINUE ENDIF C C ... LEFT FRONT EDGE (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 475 J=2,NYM1 U(1,J,NZ) = U(1,J,NZ) * + GAMMA0*BD5(1,J) * + GAMMA1*(BD5(2,J) + BD5(NXM1,J) + * BD5(1,J+1) + BD5(1,J-1) ) 475 CONTINUE ENDIF C C ... RIGHT BOTTOM EDGE (NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY) THEN DO 485 K=2,NZM1 U(NX,1,K) = U(NX,1,K) * + GAMMA0*BD1(1,K) * + GAMMA1*(BD1(2,K) + BD1(NYM1,K) + * BD1(1,K+1) + BD1(1,K-1) ) 485 CONTINUE ENDIF C C ... BOTTOM FRONT EDGE (PERIODIC/NEUMANN) C IF (PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN DO 495 I=2,NXM1 U(I,1,NZ) = U(I,1,NZ) * + GAMMA0*BD5(I,1) * + GAMMA1*(BD5(I+1,1) + BD5(I-1,1) + * BD5(I,2) + BD5(I,NYM1) ) 495 CONTINUE ENDIF C C ... RIGHT BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDZ) THEN DO 505 J=2,NYM1 U(NX,J,1) = U(NX,J,1) * + GAMMA0*BD1(J,1) * + GAMMA1*(BD1(J+1,1) + BD1(J-1,1) + * BD1(J,2) + BD1(J,NZM1) ) 505 CONTINUE ENDIF C C ... TOP BACK EDGE (NEUMANN/PERIODIC) C IF ((BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN DO 515 I=2,NXM1 U(I,NY,1) = U(I,NY,1) * + GAMMA0*BD4(I,1) * + GAMMA1*(BD4(I+1,1) + BD4(I-1,1) + * BD4(I,2) + BD4(I,NZM1) ) 515 CONTINUE ENDIF C C C ----------------------------------------- C HANDLE NEUMANN/POINTS AT PERIODIC CORNERS C ----------------------------------------- C C ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) THEN U(1,1,1) = U(1,1,1) * - GAMMA0*BD3(1,1) * - GAMMA1*(BD3(2,1) + BD3(NYM1,1) + * BD3(1,2) + BD3(1,NZM1) ) ENDIF C C ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/PERIODIC) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN U(1,1,1) = U(1,1,1) * - GAMMA0*BD2(1,1) * - GAMMA1*(BD2(2,1) + BD2(NXM1,1) + * BD2(1,2) + BD2(1,NZM1) ) ENDIF C C ... LEFT BOTTOM BACK CORNER (PERIODIC/PERIODIC/NEUMANN) C IF (PRDX .AND. PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN U(1,1,1) = U(1,1,1) * - GAMMA0*BD6(1,1) * - GAMMA1*(BD6(2,1) + BD6(NXM1,1) + * BD6(1,2) + BD6(1,NYM1) ) ENDIF C C ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(BACK) .EQ. NEUM) ) THEN U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD2(1,1) - BD6(1,1) ) * + GEDGE1*( -BD2(1,2) - BD6(1,2) ) * + GEDGE2*( -BD2(1,3) - BD6(1,3) ) * + GEDGE3*( -BD2(1,4) - BD6(1,4) ) * + GEDGE4*( -BD2(2,1) - BD6(2,1) * -BD2(NXM1,1) - BD6(NXM1,1) ) * + GEDGE5*( -BD2(2,2) - BD6(2,2) * -BD2(NXM1,2) - BD6(NXM1,2) ) ENDIF C C ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(BACK) .EQ. NEUM) ) THEN U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD3(1,1) - BD6(1,1) ) * + GEDGE1*( -BD3(1,2) - BD6(2,1) ) * + GEDGE2*( -BD3(1,3) - BD6(3,1) ) * + GEDGE3*( -BD3(1,4) - BD6(4,1) ) * + GEDGE4*( -BD3(2,1) - BD6(1,2) * -BD3(NYM1,1) - BD6(1,NYM1) ) * + GEDGE5*( -BD3(2,2) - BD6(2,2) * -BD3(NYM1,2) - BD6(2,NYM1) ) ENDIF C C ... LEFT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN U(1,1,1) = U(1,1,1) * + GEDGE0*( -BD3(1,1) - BD2(1,1) ) * + GEDGE1*( -BD3(2,1) - BD2(2,1) ) * + GEDGE2*( -BD3(3,1) - BD2(3,1) ) * + GEDGE3*( -BD3(4,1) - BD2(4,1) ) * + GEDGE4*( -BD3(1,2) - BD2(1,2) * -BD3(1,NZM1) - BD2(1,NZM1) ) * + GEDGE5*( -BD3(2,2) - BD2(2,2) * -BD3(2,NZM1) - BD2(2,NZM1) ) ENDIF C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) THEN U(NX,1,1) = U(NX,1,1) * + GAMMA0*BD1(1,1) * + GAMMA1*(BD1(2,1) + BD1(NYM1,1) + * BD1(1,2) + BD1(1,NZM1) ) ENDIF C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(RIGHT ) .EQ. NEUM) .AND. * (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN U(NX,1,1) = U(NX,1,1) * + GEDGE0*( BD1(1,1) - BD2(NX,1) ) * + GEDGE1*( BD1(2,1) - BD2(NXM1,1) ) * + GEDGE2*( BD1(3,1) - BD2(NXM2,1) ) * + GEDGE3*( BD1(4,1) - BD2(NXM3,1) ) * + GEDGE4*( BD1(1,2) - BD2(NX,2) * + BD1(1,NZM1) - BD2(NX,NZM1) ) * + GEDGE5*( BD1(2,2) - BD2(NXM1,2) * + BD1(2,NZM1) - BD2(NXM1,NZM1) ) ENDIF C C ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(BACK ) .EQ. NEUM) ) THEN U(NX,1,1) = U(NX,1,1) * + GEDGE0*( BD1(1,1) - BD6(NX,1) ) * + GEDGE1*( BD1(1,2) - BD6(NXM1,1) ) * + GEDGE2*( BD1(1,3) - BD6(NXM2,1) ) * + GEDGE3*( BD1(1,4) - BD6(NXM3,1) ) * + GEDGE4*( BD1(2,1) - BD6(NX,2) * + BD1(NYM1,1) - BD6(NX,NYM1) ) * + GEDGE5*( BD1(2,2) - BD6(NXM1,2) * + BD1(NYM1,2) - BD6(NXM1,NYM1) ) ENDIF C C ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/PERIODIC) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN U(1,NY,1) = U(1,NY,1) * + GAMMA0*BD4(1,1) * + GAMMA1*(BD4(2,1) + BD4(NXM1,1) + * BD4(1,2) + BD4(1,NZM1) ) ENDIF C C ... LEFT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(LEFT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ) THEN U(1,NY,1) = U(1,NY,1) * + GEDGE0*( -BD3(NY,1) + BD4(1,1) ) * + GEDGE1*( -BD3(NYM1,1) + BD4(2,1) ) * + GEDGE2*( -BD3(NYM2,1) + BD4(3,1) ) * + GEDGE3*( -BD3(NYM3,1) + BD4(4,1) ) * + GEDGE4*( -BD3(NY,2) + BD4(1,2) * -BD3(NY,NZM1) + BD4(1,NZM1) ) * + GEDGE5*( -BD3(NYM1,2) + BD4(2,2) * -BD3(NYM1,NZM1) + BD4(2,NZM1) ) ENDIF C C ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND. * (BCTY(BACK) .EQ. NEUM) ) THEN U(1,NY,1) = U(1,NY,1) * + GEDGE0*( BD4(1,1) - BD6(1,NY) ) * + GEDGE1*( BD4(1,2) - BD6(1,NYM1) ) * + GEDGE2*( BD4(1,3) - BD6(1,NYM2) ) * + GEDGE3*( BD4(1,4) - BD6(1,NYM3) ) * + GEDGE4*( BD4(2,1) - BD6(2,NY) * + BD4(NXM1,1) - BD6(NXM1,NY) ) * + GEDGE5*( BD4(2,2) - BD6(2,NYM1) * + BD4(NXM1,2) - BD6(NXM1,NYM1) ) ENDIF C C ... LEFT BOTTOM FRONT CORNER (PERIODIC/PERIODIC/NEUMANN) C IF (PRDX .AND. PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN U(1,1,NZ) = U(1,1,NZ) * + GAMMA0*BD5(1,1) * + GAMMA1*(BD5(2,1) + BD5(NXM1,1) + * BD5(1,2) + BD5(1,NYM1) ) ENDIF C C ... LEFT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(LEFT ) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(FRONT) .EQ. NEUM) ) THEN U(1,1,NZ) = U(1,1,NZ) * + GEDGE0*( -BD3(1,NZ) + BD5(1,1) ) * + GEDGE1*( -BD3(1,NZM1) + BD5(2,1) ) * + GEDGE2*( -BD3(1,NZM2) + BD5(3,1) ) * + GEDGE3*( -BD3(1,NZM3) + BD5(4,1) ) * + GEDGE4*( -BD3(2,NZ) + BD5(1,2) * -BD3(NYM1,NZ) + BD5(1,NYM1) ) * + GEDGE5*( -BD3(2,NZM1) + BD5(2,2) * -BD3(NYM1,NZM1) + BD5(2,NYM1) ) ENDIF C C ... LEFT BOTTOM FRONT CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. * (BCTY(FRONT ) .EQ. NEUM) ) THEN U(1,1,NZ) = U(1,1,NZ) * + GEDGE0*( -BD2(1,NZ) + BD5(1,1) ) * + GEDGE1*( -BD2(1,NZM1) + BD5(1,2) ) * + GEDGE2*( -BD2(1,NZM2) + BD5(1,3) ) * + GEDGE3*( -BD2(1,NZM3) + BD5(1,4) ) * + GEDGE4*( -BD2(2,NZ) + BD5(2,1) * -BD2(NXM1,NZ) + BD5(NXM1,1) ) * + GEDGE5*( -BD2(2,NZM1) + BD5(2,2) * -BD2(NXM1,NZM1) + BD5(NXM1,2) ) ENDIF C C ... LEFT TOP FRONT CORNER (PERIODIC/NEUMANN/NEUMANN) C IF (PRDX .AND. (BCTY(TOP ) .EQ. NEUM) .AND. * (BCTY(FRONT) .EQ. NEUM) ) THEN U(1,NY,NZ) = U(1,NY,NZ) * + GEDGE0*( BD4(1,NZ) + BD5(1,NY) ) * + GEDGE1*( BD4(1,NZM1) + BD5(1,NYM1) ) * + GEDGE2*( BD4(1,NZM2) + BD5(1,NYM2) ) * + GEDGE3*( BD4(1,NZM3) + BD5(1,NYM3) ) * + GEDGE4*( BD4(2,NZ) + BD5(2,NY) * + BD4(NXM1,NZ) + BD5(NXM1,NY) ) * + GEDGE5*( BD4(2,NZM1) + BD5(2,NYM1) * + BD4(NXM1,NZM1) + BD5(NXM1,NYM1) ) ENDIF C C ... RIGHT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. * (BCTY(FRONT) .EQ. NEUM) ) THEN U(NX,1,NZ) = U(NX,1,NZ) * + GEDGE0*( BD1(1,NZ) + BD5(NX,1) ) * + GEDGE1*( BD1(1,NZM1) + BD5(NXM1,1) ) * + GEDGE2*( BD1(1,NZM2) + BD5(NXM2,1) ) * + GEDGE3*( BD1(1,NZM3) + BD5(NXM3,1) ) * + GEDGE4*( BD1(2,NZ) + BD5(NX,2) * + BD1(NYM1,NZ) + BD5(NX,NYM1) ) * + GEDGE5*( BD1(2,NZM1) + BD5(NXM1,2) * + BD1(NYM1,NZM1) + BD5(NXM1,NYM1) ) ENDIF C C ... RIGHT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC) C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. * (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ) THEN U(NX,NY,1) = U(NX,NY,1) * + GEDGE0*( BD1(NY,1) + BD4(NX,1) ) * + GEDGE1*( BD1(NYM1,1) + BD4(NXM1,1) ) * + GEDGE2*( BD1(NYM2,1) + BD4(NXM2,1) ) * + GEDGE3*( BD1(NYM3,1) + BD4(NXM3,1) ) * + GEDGE4*( BD1(NY,2) + BD4(NX,2) * + BD1(NY,NZM1) + BD4(NX,NZM1) ) * + GEDGE5*( BD1(NYM1,2) + BD4(NXM1,2) * + BD1(NYM1,NZM1) + BD4(NXM1,NZM1) ) ENDIF C C C ---- C EXIT C ---- C 999 CONTINUE RETURN END SUBROUTINE MDALG3 (A, B, C, D, BCTY, U, LDXU, LDYU, IL, IR, * JL, JR, KL, KR, WORK) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C C DECEMBER 1985 (REVISED APRIL 1987) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C MDALG3 IMPLEMENTS THE MATRIX DECOMPOSITION ALGORITHM (FOURIER C METHOD FOR A NINE-POINT DIFFERENCE OPERATOR ON A THREE-DIMENSIONAL C RECTANGULAR GRID. C C C P A R A M E T E R S C ------------------- C C A, B, C, D REAL SCALARS (INPUT) C GIVE THE BASIC FINITE DIFFERENCE STENCIL THAT IS C USED TO APPROXIMATE THE PDE. C C D C D C C B C C D C D C C C B C C B A B U = RIGHT HAND SIDE C C B C C C D C D C C B C C D C D C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C U REAL ARRAY OF SIZE LDXU BY LDYU BY KR (INPUT/OUTPUT) C ON INPUT, U CONTAINS THE RIGHT HAND SIDE OF THE C DISCRETE APPROXIMATION TO THE PDE FOR EACH POINT C POINT AT WHICH THE SOLUTION IS TO BE DETERMINED, C I.E., (I,J,K), I=IL,..,IR, J=JL,..,JR, K=KL,..,KR. C ON OUTPUT, THESE VALUES ARE REPLACED BY THE COMPUTED C SOLUTION. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C LDYU INTEGER SCALAR (INPUT) C THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C IL, IR, INTEGER SCALARS (INPUT) C JL, JR, GIVES THE SUBSET OF GRID POINTS AT WHICH THE C KL, KR SOLUTION IS TO BE DETERMINED, I.E., THAT SET C OF INDICES (I,J) WITH I=IL,..,IR, J=JL,..,JR, AND C K=KL,..,KR. C C WORK REAL ARRAY OF SIZE N*L + 5N + 5M + 3L + N/2 + L/2 +30 C HERE N=IR-IL+1, M=JR-JL+1, AND L=KR-KL+1. THE LENGTH C OF THIS ARRAY MAY BE REDUCED BY M WHEN THE SOLUTION C IS NOT PERIODIC IN Y, AND MAY BE REDUCED BY 4M WHEN C THE COEFFICIENT OF U IN THE PDE IS .LE. 0. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(6), LDXU, LDYU, IL, IR, JL, JR, KL, KR REAL * A, B, C, D, U(LDXU,LDYU,*), WORK(*) C C ... LOCAL VARIABLES C INTEGER N, M, L, LOCWSA, LOCMWK, TOTAL C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C -------------- C INITIALIZATION C -------------- C N = IR - IL + 1 M = JR - JL + 1 L = KR - KL + 1 LOC WSA = 1 + N*L LOC MWK = LOC WSA + (3*L + L/2 + 15) TOTAL = LOC MWK + 5*N + 5*M + N/2 + 14 C CALL FFTI(BCTY(BACK),BCTY(FRONT),L,WORK(LOCWSA)) C C C ------------------ C FORWARD TRANSFORMS C ------------------ C DO 100 J=JL,JR KK = 0 DO 25 I=IL,IR DO 25 K=KL,KR KK = KK + 1 WORK(KK) = U(I,J,K) 25 CONTINUE CALL FFTF(BCTY(BACK),BCTY(FRONT),WORK,L,1,L,1,N,WORK(LOCWSA)) KK = 0 DO 75 I=IL,IR DO 75 K=KL,KR KK = KK + 1 U(I,J,K) = WORK(KK) 75 CONTINUE 100 CONTINUE C C C -------------------------------- C SOLVE N TWO-DIMENSIONAL PROBLEMS C -------------------------------- C CALL EVDISC(BCTY(BACK),BCTY(FRONT),WORK(KL),L) DO 200 K=KL,KR EVA = A + B*WORK(K) EVB = B + C*WORK(K) EVC = C + D*WORK(K) CALL MDALG2(EVA,EVB,EVC,BCTY,U(1,1,K),LDXU,IL,IR,JL,JR, * WORK(LOCMWK)) 200 CONTINUE C C ------------------- C BACKWARD TRANSFORMS C ------------------- C DO 300 J=JL,JR KK = 0 DO 225 I=IL,IR DO 225 K=KL,KR KK = KK + 1 WORK(KK) = U(I,J,K) 225 CONTINUE CALL FFTB(BCTY(BACK),BCTY(FRONT),WORK,L,1,L,1,N,WORK(LOCWSA)) KK = 0 DO 275 I=IL,IR DO 275 K=KL,KR KK = KK + 1 U(I,J,K) = WORK(KK) 275 CONTINUE 300 CONTINUE C C C ---- C EXIT C ---- C RETURN END SUBROUTINE REFL3 (KDIST, NX, NY, NZ, PRDX, PRDY, PRDZ, G, * LMXG, LMYG) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C REFL3 EXTENDS A THREE-DIMENSIONAL GRID FUNCTION SO THAT IT IS C DEFINED ONE GRID LINE OUTSIDE ITS ORIGINAL DOMAIN. THE EXTENSION C IS DONE BY REFLECTION THROUGH THE BOUNDARY EXCEPT WHERE C PERIODICITY IS SPECIFIED. C C C P A R A M E T E R S C ------------------- C C KDIST INTEGER SCALAR (INPUT) C INDICATES HOW THE GRID FUNCTION IS DEFINED. C POSSIBLE VALUES ARE C C 1 == FUNCTION DEFINED AT CENTER OF GRID SQUARES C 2 == FUNCTION DEFINED AT GRID POINTS C C NX INTEGER SCALAR (INPUT) C THE NUMBER OF GRID FUNCTION VALUES IN THE X DIRECTION. C C NY INTEGER SCALAR (INPUT) C THE NUMBER OF GRID FUNCTION VALUES IN THE Y DIRECTION. C C NZ INTEGER SCALAR (INPUT) C THE NUMBER OF GRID FUNCTION VALUES IN THE Z DIRECTION. C C PRDX LOGICAL SCALAR (INPUT) C .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY C IN X. C C PRDY LOGICAL SCALAR (INPUT) C .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY C IN Y. C C PRDZ LOGICAL SCALAR (INPUT) C .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY C IN Z. C C G REAL ARRAY OF SIZE LMXG+1 BY LMYG+1 BY NZ+1 (INPUT/OUTPUT) C ON INPUT, THE GRID FUNCTION OCCUPIES G(I,J,K), I=1,..,NX, C J=1,..,NY, K=1,..,NZ. C ON OUTPUT, THE FUNCTION HAS BEEN EXTENDED TO INCLUDE THE C POINTS G(0,J,K), G(NX+1,J,K), G(I,0,K), G(I,NY+1,K), C G(I,J,0), G(I,J,NZ+1), I=0,..,NX+1, J=0,..,NY+1, C K=0,..,NZ+1. C C LMXG INTEGER SCALAR (INPUT) C THE UPPER LIMIT OF THE FIRST DIMENSION OF THE ARRAY G. C MUST BE SET TO LDXU-1, WHERE LDXU IS THE ACTUAL LENGTH OF C THE FIRST DIMENSION OF G AS DECLARED IN THE CALLING C PROGRAM. C C LMYG INTEGER SCALAR (INPUT) C THE UPPER LIMIT OF THE SECOND DIMENSION OF THE ARRAY G. C MUST BE SET TO LDYU-1, WHERE LDYU IS THE ACTUAL LENGTH OF C THE SECOND DIMENSION OF G AS DECLARED IN THE CALLING C PROGRAM. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C LOGICAL PRDX, PRDY, PRDZ INTEGER KDIST, NX, NY, NZ, LMXG, LMYG REAL * G(0:LMXG,0:LMYG,0:*) C C C --------------- C INITIALIZATIONS C --------------- C NXP1 = NX + 1 NYP1 = NY + 1 NZP1 = NZ + 1 C I0 = 1 + KDIST J0 = 1 + KDIST K0 = 1 + KDIST I1 = NX - KDIST J1 = NY - KDIST K1 = NZ - KDIST C C C ----------- C REFLECTIONS C ----------- C C ... IN Z DIRECTION C DO 10 I=1,NX DO 10 J=1,NY G(I,J,0) = G(I,J,K0) G(I,J,NZP1) = G(I,J,K1) 10 CONTINUE C C ... IN X DIRECTION C DO 20 J=1,NY DO 20 K=0,NZP1 G(0,J,K) = G(I0,J,K) G(NXP1,J,K) = G(I1,J,K) 20 CONTINUE C C ... IN Y DIRECTION C DO 30 I=0,NXP1 DO 30 K=0,NZP1 G(I,0,K) = G(I,J0,K) G(I,NYP1,K) = G(I,J1,K) 30 CONTINUE C C C ------------------- C PERIODIC EXTENSIONS C ------------------- C C ... IN X DIRECTIONS C IF (PRDX) THEN DO 40 J=0,NYP1 DO 40 K=0,NZP1 G(0,J,K) = G(NXP1,J,K) 40 CONTINUE ENDIF C C ... IN Y DIRECTION C IF (PRDY) THEN DO 50 I=0,NXP1 DO 50 K=0,NZP1 G(I,0,K) = G(I,NYP1,K) 50 CONTINUE ENDIF C C ... IN Z DIRECTION C IF (PRDZ) THEN DO 60 I=0,NXP1 DO 60 J=0,NYP1 G(I,J,0) = G(I,J,NZP1) 60 CONTINUE ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE STORD3 (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6, * LDXBD, LDYBD, U, LDXU, LDYU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C STORD3 STORES GIVEN DIRICHLET BOUNDARY DATA INTO THE SOLUTION ARRAY. C C C P A R A M E T E R S C ------------------- C C NX,NY,NZ INTEGER SCALARS (INPUT) C SEE HFFT3A. C C BCTY INTEGER ARRAY OF SIZE 6 (INPUT) C SEE HFFT3A. C C BD1, BD3 REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT) C SEE HFFT3A. C C BD2, BD4 REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT) C SEE HFFT3A. C C BD5, BD6 REAL ARRAYS OF SIZE LDXBD BY NY (INPUT) C SEE HFFT3A. C C LDXBD INTEGER SCALARS (INPUT) C LDYBD SEE HFFT3A. C C U REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT) C ON OUTPUT, ELEMENTS CORRESPONDING TO DIRICHLET BOUNDARY C POINTS CONTAIN THE KNOWN VALUES OF THE SOLUTION THERE. C C LDXU INTEGER SCALARS (INPUT) C LDYU SEE HFFT3A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, NZ, BCTY(6), LDXBD, LDYBD, LDXU, LDYU REAL * BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ), * BD5(LDXBD,NY), BD6(LDXBD,NY), U(LDXU,LDYU,NZ) C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6) C C C ---------------------- C HANDLE DIRICHLET SIDES C ---------------------- C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .EQ. DRCH) THEN DO 205 K=1,NZ DO 205 I=1,NX U(I,1,K) = BD2(I,K) 205 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .EQ. DRCH) THEN DO 215 K=1,NZ DO 215 I=1,NX U(I,NY,K) = BD4(I,K) 215 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .EQ. DRCH) THEN DO 225 K=1,NZ DO 225 J=1,NY U(1,J,K) = BD3(J,K) 225 CONTINUE ENDIF C C ... RIGHT SIDE C IF (BCTY(RIGHT) .EQ. DRCH) THEN DO 235 K=1,NZ DO 235 J=1,NY U(NX,J,K) = BD1(J,K) 235 CONTINUE ENDIF C C ... FRONT SIDE C IF (BCTY(FRONT) .EQ. DRCH) THEN DO 245 J=1,NY DO 245 I=1,NX U(I,J,NZ) = BD5(I,J) 245 CONTINUE ENDIF C C ... BACK SIDE C IF (BCTY(BACK) .EQ. DRCH) THEN DO 255 J=1,NY DO 255 I=1,NX U(I,J,1) = BD6(I,J) 255 CONTINUE ENDIF C C C ---- C EXIT C ---- C RETURN END * SUBROUTINE HFFT2 (COEFU, PRHS, BRHS, AX, BX, AY, BY, NX, NY, * BCTY, IORDER, U, LDXU, WORK, NWORK, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C HFFT2 = 2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT2A = 2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C HFFT3 = 3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT3A = 3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C P U R P O S E C ------------- C C HFFT2 SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES C ON A TWO-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION C OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS. C C C D E S C R I P T I O N C --------------------- C C HFFT2 SOLVES THE EQUATION C C 2 2 C D U + D U C --- + --- + COEFU*U = G C 2 2 C DX DY C C C ON THE RECTANGULAR DOMAIN (AX,BX)X(AY,BY) C C TOP (SIDE 4) C Y=BY ---------------------------- C : : C : : C LEFT : : RIGHT C : : C (SIDE 3) : : (SIDE 1) C : : C : : C Y=AY ---------------------------- C X=AX BOTTOM (SIDE 2) X=BX C C WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN C (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS. C C THE OUTPUT OF THIS PROGRAM IS A TWO-DIMENSIONAL ARRAY GIVING C ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J)), FOR C I=1,..,NX AND J=1,..,NY, WHERE C C X(I) = AX + (I-1)*HX C Y(J) = AY + (J-1)*HY C HX = (BX-AX)/(NX-1) C HY = (BY-AY)/(NY-1) C C THE USER MUST CHOOSE NX AND NY SO THAT THE GRID SPACING IS THE SAME C IN BOTH X AND Y, I.E., HX = HY. C C WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE C PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO C OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION C OF MINIMUM INFINITY NORM IS RETURNED. C C THE SOLUTION IS COMPUTED USING EITHER A SECOND OR FOURTH ORDER C ACCURATE FINITE DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. C THE RESULTING SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING C FAST FOURIER TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE C FACT THAT NX-1 IS HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES). C C C P A R A M E T E R S C ------------------- C C COEFU REAL SCALAR (INPUT) C THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION. C C PRHS REAL FUNCTION OF X,Y (INPUT) C RETURNS THE RIGHT-HAND SIDE OF THE DIFFERENTIAL EQUATION C FOR ANY (X,Y) IN THE DOMAIN OR ON THE BOUNDARY (SEE C DESCRIPTION BELOW). THE NAME OF THIS FUNCTION MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. C C BRHS REAL FUNCTION OF K,X,Y (INPUT) C RETURNS THE RIGHT-HAND SIDE OF THE BOUNDARY CONDITION AT C THE POINT (X,Y) ON THE K-TH SIDE OF THE DOMAIN (SEE C DESCRIPTION BELOW). THE NAME OF THIS FUNCTION MUST BE C DECLARED EXTERNAL IN THE CALLING PROGRAM. C C AX REAL SCALAR (INPUT) .LT. BX C THE VALUE OF X ALONG THE LEFT SIDE OF THE DOMAIN. C C BX REAL SCALAR (INPUT) C THE VALUE OF X ALONG THE RIGHT SIDE OF THE DOMAIN. C C AY REAL SCALAR (INPUT) .LT. BY C THE VALUE OF Y ALONG THE BOTTOM SIDE OF THE DOMAIN. C C BY REAL SCALAR (INPUT) C THE VALUE OF Y ALONG THE TOP SIDE OF THE DOMAIN. C C NX INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN X. C (THE NUMBER OF VERTICAL PANELS IS THEN NX-1.) C NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C NY INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Y. C (THE NUMBER OF HORIZONTAL PANELS IS THEN NY-1.) C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE C DOMAIN AS FOLLOWS. C C BCTY(1) = TYPE ON RIGHT SIDE (X=BX) C BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY) C BCTY(3) = TYPE ON LEFT SIDE (X=AX) C BCTY(4) = TYPE ON TOP SIDE (Y=BY) C C POSSIBLE VALUES ARE C C 1 == U PRESCRIBED C 2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR C DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) C 3 == PERIODIC C C IORDER INTEGER SCALAR (INPUT) C THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE C APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE C C 2 == SECOND ORDER ACCURATE COMPACT 9-POINT DIFFERENCES C 4 == FOURTH ORDER ACCURATE COMPACT 9-POINT DIFFERENCES C C U REAL ARRAY OF SIZE LDXU BY NY+2 (OUTPUT) C THE SOLUTION OF THE PDE PROBLEM. C U(I,J) IS THE VALUE OF THE COMPUTED SOLUTION AT THE POINT C (X(I),Y(J)). ROWS NX+1 AND NX+2 AND COLUMNS NY+1 AND C NY+2 ARE USED AS WORKING STORAGE. C C LDXU INTEGER SCALAR (INPUT) .GE. NX+2 C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C WORK REAL ARRAY OF SIZE NWORK. C WORKING STORAGE REQUIRED BY HFFT2. C C NWORK INTEGER SCALAR (INPUT) .GE. (NX+1)*(NY+1)*(IORDER-2)/2 C + 7*NX + 7*NY + NX/2 + 15. THE LENGTH OF THE ARRAY WORK AS C DECLARED IN THE CALLING PROGRAM. THIS MAY BE REDUCED BY C 4*NY IF COEFU.LE.0. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY C CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE C PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE C RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED. C THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT C SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN C ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN C 1 == WARNING. COEFU.GT.0 A SOLUTION MAY NOT EXIST IF C COEFU IS AN EIGENVALUE OF THE LAPLACIAN. IF COEFU C IS NEAR ONE OF THESE VALUES THEN THE COMPUTED C SOLUTION MAY BE UNRELIABLE. C 0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION. C -1 == ERROR. NX.LT.4 C -2 == ERROR. NY.LT.4 C -3 == ERROR. LDXU.LT.NX+2 C -4 == ERROR. IORDER NOT 2 OR 4. C -5 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3. C -6 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON C ONE SIDE OF DOMAIN BUT NOT THE OPPOSITE SIDE C -7 == ERROR. NWORK TOO SMALL. C -8 == ERROR. BX.LT.AX C -9 == ERROR. BY.LT.AY C -10 == ERROR. GRID SIZE IN X NOT SAME AS IN Y. C C C U S E R - D E F I N E D F U N C T I O N S C ------------------------------------------- C C THE RIGHT HAND SIDE (FORCING FUNCTION) OF THE PARTIAL C DIFFERENTIAL EQUATION IS SPECIFIED BY THE FUNCTION PRHS. C C REAL FUNCTION PRHS (X,Y) C REAL X,Y C PRHS = RIGHT SIDE OF THE PDE AT (X,Y) C RETURN C END C C THE VALUE OF THE SOLUTION OR ITS FIRST DERIVATIVE ALONG THE C EDGES OF THE DOMAIN WHERE BCTY=1 OR 2 IS SUPPLIED VIA THE C FUNCTION BRHS. C C REAL FUNCTION BRHS (K,X,Y) C INTEGER K C REAL X,Y C BRHS = RIGHT HAND SIDE OF KTH BOUNDARY CONDITION C (SEE BCTY) AT THE POINT (X,Y) C RETURN C END C C C E X T E R N A L R E F E R E N C E S C ------------------------------------- C C HFFT2A,FDIS2,HDIS2,FD2N, C STORD2,FD2D,HD2N,REFL2, C MDALG2,EVDISC,TRISOL, C TRSALL,TRSOLG,TRSOLP, C SGPSL,FFTI,FFTB,FFTF -- THIS PACKAGE C C RFFTI,RFFTF,RFFTB, C SINTI,SINT,COSTI,COST, C SINQI,SINQF,SINQB, C COSQI,COSQF,COSQB -- FFTPACK (SEE REF. 2) C C R1MACH -- MACHINE CONSTANTS (SEE REF. 3) C C PRHS,BRHS -- USER-SUPPLIED C C C P O R T A B I L I T Y C --------------------- C C THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977). C ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE C FUNCTION R1MACH (SEE REF. 3). C C C R E F E R E N C E S C ------------------- C C 1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD C FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS C II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS, C ORLANDO, FLA., 1984, 35-44. C C 2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE C PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS C ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3). C FFTPACK IS DESCRIBED IN C C P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL C COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, C PP. 51-83. C C FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE, C COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH, C BOX 3000, BOULDER, CO 80303, USA. C C 3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK C FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978), C PP. 177-188. C C 4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS, C HOLT, RINEHART AND WINSTON, NEW YORK, 1967. C C C A U T H O R / V E R S I O N C ----------------------------- C C RONALD F. BOISVERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C GAITHERSBURG, MD 20899 C USA C C ORIGINAL DECEMBER 1987 C REVISED APRIL 1987 C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, BCTY(4), IORDER, LDXU, NWORK, INFO REAL * COEFU, AX, BX, AY, BY, U(LDXU,*), WORK(NWORK) C C ... LOCAL VARIABLES C INTEGER LOCGH, LOCBD1, LOCBD2, LOCBD3, LOCBD4, LOCWRK, NWORKA, * NEEDED, LOC, NXM1, NYM1, NXP1, NYP1, NXP2, NYP2 REAL * R1MACH, EPSM, PRHS, BRHS, H, HX, HY, AXH, AYH, X, Y C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NXP1 = NX + 1 NYP1 = NY + 1 NXP2 = NX + 2 NYP2 = NY + 2 C H = (BX-AX)/REAL(NXM1) EPSM = R1MACH(4) C LOC GH = 1 LOC BD1 = LOC GH IF (IORDER .EQ. 4) LOC BD1 = LOC GH + NXP1*NYP1 LOC BD2 = LOC BD1 + NY LOC BD3 = LOC BD2 + NX LOC BD4 = LOC BD3 + NY LOC WRK = LOC BD4 + NX NEEDED = LOC WRK + 5*NX + 5*NY + NX/2 + 14 NWORKA = NWORK - LOCWRK + 1 C C C --------------------------- C CHECK VALIDITY OF ARGUMENTS C --------------------------- C INFO = 0 IF (NX .LT. 4) GO TO 901 IF (NY .LT. 4) GO TO 902 IF (LDXU .LT. NX+2) GO TO 903 IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 904 DO 10 K=1,4 IF ((BCTY(K) .LT. 1) .OR. (BCTY(K) .GT. 3)) GO TO 905 10 CONTINUE IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT ) .NE. PRDC)) .OR. * ((BCTY(LEFT ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR. * ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP ) .NE. PRDC)) .OR. * ((BCTY(TOP ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) ) * GO TO 906 IF (NWORK .LT. NEEDED) GO TO 907 IF (BX .LE. AX) GO TO 908 IF (BY .LE. AY) GO TO 909 HX = H HY = (BY-AY)/REAL(NYM1) IF (ABS(HX-HY) .GT. EPSM) GO TO 910 C C C ------------------ C COMPUTE RHS OF PDE C ------------------ C C ... AT GRID POINTS C DO 100 J=1,NY Y = AY + REAL(J-1)*H DO 100 I=1,NX X = AX + REAL(I-1)*H U(I,J) = PRHS(X,Y) 100 CONTINUE C C ... AT HALF GRID POINTS C IF (IORDER .EQ. 4) THEN AXH = AX + 0.50E0*H AYH = AY + 0.50E0*H DO 200 J=1,NYM1 Y = AYH + REAL(J-1)*H K = LOC GH + J*NXP1 DO 200 I=1,NXM1 X = AXH + REAL(I-1)*H K = K + 1 WORK(K) = PRHS(X,Y) 200 CONTINUE ENDIF C C C ------------------ C LOAD BOUNDARY DATA C ------------------ C C ... RIGHT SIDE C IF (BCTY(RIGHT) .NE. PRDC) THEN LOC = LOC BD1 - 1 DO 310 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(RIGHT,BX,Y) 310 CONTINUE ENDIF C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .NE. PRDC) THEN LOC = LOC BD2 - 1 DO 320 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(BOTTOM,X,AY) 320 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .NE. PRDC) THEN LOC = LOC BD3 - 1 DO 330 J=1,NY Y = AY + REAL(J-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(LEFT,AX,Y) 330 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .NE. PRDC) THEN LOC = LOC BD4 - 1 DO 340 I=1,NX X = AX + REAL(I-1)*H LOC = LOC + 1 WORK(LOC) = BRHS(TOP,X,BY) 340 CONTINUE ENDIF C C C ---------------- C CALL FAST SOLVER C ---------------- C CALL HFFT2A(COEFU,NX,NY,H,WORK(LOCGH),NXP1,BCTY,WORK(LOCBD1), * WORK(LOCBD2),WORK(LOCBD3),WORK(LOCBD4),IORDER, * U,LDXU,WORK(LOCWRK),NWORKA,INFO) C C C ----------- C NORMAL EXIT C ----------- C WORK(1) = WORK(LOCWRK) GO TO 999 C C C ----------- C ERROR EXITS C ----------- C 901 CONTINUE INFO = -1 GO TO 999 C 902 CONTINUE INFO = -2 GO TO 999 C 903 CONTINUE INFO = -3 GO TO 999 C 904 CONTINUE INFO = -4 GO TO 999 C 905 CONTINUE INFO = -5 GO TO 999 C 906 CONTINUE INFO = -6 GO TO 999 C 907 CONTINUE INFO = -7 GO TO 999 C 908 CONTINUE INFO = -8 GO TO 999 C 909 CONTINUE INFO = -9 GO TO 999 C 910 CONTINUE INFO = -10 GO TO 999 C 999 CONTINUE RETURN END SUBROUTINE HFFT2A (COEFU, NX, NY, H, GH, LDXGH, BCTY, BD1, BD2, * BD3, BD4, IORDER, U, LDXU, WORK, NWORK, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C HFFT2 = 2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT2A = 2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C HFFT3 = 3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS C HFFT3A = 3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C P U R P O S E C ------------- C C HFFT2A SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES C ON A TWO-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION C OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS. C C C D E S C R I P T I O N C --------------------- C C HFFT2A SOLVES THE EQUATION C C 2 2 C D U + D U C --- + --- + COEFU*U = G C 2 2 C DX DY C C ON THE RECTANGULAR DOMAIN (AX,BX)X(AY,BY) C C TOP (SIDE 4) C Y=BY ---------------------------- C : : C : : C LEFT : : RIGHT C : : C (SIDE 3) : : (SIDE 1) C : : C : : C Y=AY ---------------------------- C X=AX BOTTOM (SIDE 2) X=BX C C WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN C (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS. C C THE OUTPUT OF THIS PROGRAM IS A TWO-DIMENSIONAL ARRAY GIVING C ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J)), FOR C I=1,..,NX AND J=1,..,NY, WHERE C C X(I) = AX + (I-1)*H C Y(J) = AY + (J-1)*H C C AX IS THE X-COORDINATE OF THE LEFT EDGE OF THE RECTANGLE AND AY IS C THE Y-COORDINATE OF THE BOTTOM EDGE OF THE RECTANGLE. C C WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE C PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO C OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION C OF MINIMUM INFINITY NORM IS RETURNED. C C THE SOLUTION IS COMPUTED USING EITHER A SECOND OR FOURTH ORDER C ACCURATE FINITE DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. C THE RESULTING SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING C FAST FOURIER TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE C FACT THAT NX-1 IS HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES). C C C P A R A M E T E R S C ------------------- C C COEFU REAL SCALAR (INPUT) C THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION. C C NX INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN X. C (THE NUMBER OF VERTICAL PANELS IS THEN NX-1.) C NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE C (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED C OF THE FOURIER TRANSFORM ALGORITHM. C C NY INTEGER SCALAR (INPUT) .GE. 4 C THE NUMBER OF GRID LINES IN Y. C (THE NUMBER OF HORIZONTAL PANELS IS THEN NY-1.) C C H REAL SCALAR (INPUT) C THE SPACE BETWEEN ADJACENT GRID LINES (IN BOTH X AND Y). C C GH REAL ARRAY OF SIZE LDXGH BY NY+1 (INPUT) C THE RIGHT HAND SIDE OF THE PDE AT HALF GRID POINTS. C G(I+1,J+1) IS THE VALUE OF THE RIGHT HAND SIDE AT THE C (I,J)TH HALF GRID POINT, I=1,..,NX-1, J=1,..,NY-1. THAT IS, C C GH(I+1,J+1) = G(XH(I),YH(J)) C XH(I) = AX + (I-0.5)*H C YH(J) = AY + (J-0.5)*H C C THE FIRST AND LAST ROWS AND COLUMNS OF GH ARE USED AS C WORKING STORAGE. GH IS NOT USED WHEN IORDER=2. C C LDXGH INTEGER SCALAR (INPUT) .GE. NX+1 C THE LEADING DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE C DOMAIN AS FOLLOWS. C C BCTY(1) = TYPE ON RIGHT SIDE (X=BX) C BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY) C BCTY(3) = TYPE ON LEFT SIDE (X=AX) C BCTY(4) = TYPE ON TOP SIDE (Y=BY) C C POSSIBLE VALUES ARE C C 1 == U PRESCRIBED C 2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR C DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) C 3 == PERIODIC C C BD1 REAL ARRAY OF SIZE NY (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE RIGHT SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(1) VALUE STORED C ------------------------------ C 1 U C 2 DU/DX C 3 NONE C C BD1(J) GIVES THE VALUE AT THE POINT (BX,Y(J)). C C BD2 REAL ARRAY OF SIZE NX (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE BOTTOM SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(2) VALUE STORED C ------------------------------ C 1 U C 2 DU/DY C 3 NONE C C BD2(I) GIVES THE VALUE AT THE POINT (X(I),AY). C C BD3 REAL ARRAY OF SIZE NY (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE LEFT SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(3) VALUE STORED C ------------------------------ C 1 U C 2 DU/DX C 3 NONE C C BD3(J) GIVES THE VALUE AT THE POINT (AX,Y(J)). C C BD4 REAL ARRAY OF SIZE NX (INPUT) C THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON C THE BOTTOM SIDE OF THE DOMAIN. THE VALUE STORED DEPENDS C UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS C C BCTY(4) VALUE STORED C ------------------------------ C 1 U C 2 DU/DY C 3 NONE C C BD4(I) GIVES THE VALUE AT THE POINT (X(I),BY). C C IORDER INTEGER SCALAR (INPUT) C THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE C APPROXIMATION OF THE PARTIAL DIFFERENTIAL EQUATION. C POSSIBLE VALUES ARE C C 2 == 2ND ORDER ACCURATE 9-POINT COMPACT DIFFERENCES C 4 == 4TH ORDER ACCURATE 9-POINT COMPACT DIFFERENCES C C U REAL ARRAY OF SIZE LDXU BY NY+2 (INPUT/OUTPUT) C ON INPUT, U(I,J) IS THE VALUE OF THE RIGHT HAND SIDE OF C THE PARTIAL DIFFERENTIAL EQUATION AT THE (I,J)TH GRID C POINT. THAT IS, C C U(I,J) = G(X(I),Y(J)), I=1,..,NX, J=1,..,NY C C ON OUTPUT, U(I,J) IS THE VALUE OF THE COMPUTED SOLUTION C AT (X(I),Y(J)). ROWS NX+1 AND NX+2 AND COLUMNS NY+1 AND C NY+2 ARE USED FOR WORKING STORAGE. C C LDXU INTEGER SCALAR (INPUT) .GE. NX+2 C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED C IN THE CALLING PROGRAM. C C WORK REAL ARRAY OF SIZE NWORK. C WORKING STORAGE REQUIRED BY HFFT2A. C C NWORK INTEGER SCALAR (INPUT) .GE. 5*NX + 5*NY + NX/2 + 15 C THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING C PROGRAM. THIS MAY BE REDUCED BY 4*NY IS COEFU.LE.0. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY C CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE C PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE C RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED. C THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT C SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN C ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN C ADDITIVE CONSTANT. C 1 == WARNING. COEFU.GT.0 A SOLUTION MAY NOT EXIST IF C COEFU IS AN EIGENVALUE OF THE LAPLACIAN. IF COEFU C IS NEAR ONE OF THESE VALUES THEN THE COMPUTED C SOLUTION MAY BE UNRELIABLE. C 0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION. C -1 == ERROR. NX.LT.4 C -2 == ERROR. NY.LT.4 C -3 == ERROR. LDXU.LT.NX+2 C -4 == ERROR. IORDER NOT 2 OR 4. C -5 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3. C -6 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON C ONE SIDE OF DOMAIN BUT NOT THE OPPOSITE SIDE C -7 == ERROR. NWORK TOO SMALL. C -8 == ERROR. LDXGH.LT.NX+1 C C C E X T E R N A L R E F E R E N C E S C ------------------------------------- C C FDIS2,HDIS2,FD2N, C STORD2,FD2D,HD2N,REFL2, C MDALG2,EVDISC,TRISOL, C TRSALL,TRSOLG,TRSOLP, C SGPSL,FFTI,FFTB,FFTF -- THIS PACKAGE C C RFFTI,RFFTF,RFFTB, C SINTI,SINT,COSTI,COST, C SINQI,SINQF,SINQB, C COSQI,COSQF,COSQB -- FFTPACK (SEE REF. 2) C C R1MACH -- MACHINE CONSTANTS (SEE REF. 3) C C C P O R T A B I L I T Y C --------------------- C C THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977). C ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE C FUNCTION R1MACH (SEE REF. 3). C C C R E F E R E N C E S C ------------------- C C 1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD C FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS C II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS, C ORLANDO, FLA., 1984, 35-44. C C 2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE C PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS C ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3). C FFTPACK IS DESCRIBED IN C C P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL C COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, C PP. 51-83. C C FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE, C COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH, C BOX 3000, BOULDER, CO 80303, USA. C C 3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK C FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978), C PP. 177-188. C C 4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS, C HOLT, RINEHART AND WINSTON, NEW YORK, 1967. C C C A U T H O R / V E R S I O N C ----------------------------- C C RONALD F. BOISVERT C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C GAITHERSBURG, MD 20899 C USA C C ORIGINAL DECEMBER 1985 C REVISED APRIL 1987 C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, IORDER, LDXGH, LDXU, BCTY(4), NWORK, INFO REAL * H, COEFU, GH(LDXGH,*), U(LDXU,*), WORK(NWORK), * BD1(NY), BD2(NX), BD3(NY), BD4(NX) C C ... LOCAL VARIABLES C LOGICAL SNGULR, PRDX, PRDY INTEGER NXM1, NYM1, NM, NEEDED REAL * EPSM, R1MACH, A, B, C, FX, FY, FACTOR, SCALE, PERTRB, UNORM C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C EPSM = R1MACH(4) C NXM1 = NX - 1 NYM1 = NY - 1 C SNGULR = (BCTY(RIGHT ) .NE. DRCH) .AND. * (BCTY(BOTTOM) .NE. DRCH) .AND. * (BCTY(LEFT ) .NE. DRCH) .AND. * (BCTY(TOP ) .NE. DRCH) .AND. * (ABS(COEFU) .LT. R1MACH(4)) PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C IL = 1 IR = NX JL = 1 JR = NY IF (BCTY(RIGHT ) .EQ. DRCH) IR = NXM1 IF (BCTY(BOTTOM) .EQ. DRCH) JL = 2 IF (BCTY(LEFT ) .EQ. DRCH) IL = 2 IF (BCTY(TOP ) .EQ. DRCH) JR = NYM1 IF (PRDX) IR = NXM1 IF (PRDY) JR = NYM1 NM = (IR-IL+1)*(JR-JL+1) C C C --------------------------- C CHECK VALIDITY OF ARGUMENTS C --------------------------- C INFO = 0 IF (NX .LT. 4) GO TO 901 IF (NY .LT. 4) GO TO 902 IF (LDXU .LT. NX+2) GO TO 903 IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 904 DO 10 K=1,4 IF ((BCTY(K) .LT. 1) .OR. (BCTY(K) .GT. 3)) GO TO 905 10 CONTINUE IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT ) .NE. PRDC)) .OR. * ((BCTY(LEFT ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR. * ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP ) .NE. PRDC)) .OR. * ((BCTY(TOP ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) ) * GO TO 906 NEEDED = 5*NX + 5*NY + NX/2 + 15 IF (NWORK .LT. NEEDED) GO TO 907 IF (LDXGH .LT. NX+1) GO TO 908 C IF (COEFU .GT. 0.0E0) INFO = 1 IF (SNGULR) INFO = 2 C C C ---------- C DISCRETIZE C ---------- C IF (IORDER .EQ. 4) THEN CALL HDIS2(NX,NY,H,COEFU,GH,LDXGH-1,BCTY,BD1,BD2,BD3,BD4, * A,B,C,U,LDXU-1,WORK) ELSE CALL FDIS2(NX,NY,H,COEFU,BCTY,BD1,BD2,BD3,BD4, * A,B,C,U,LDXU) ENDIF C C --------------------------------------- C ADJUST FOR CONSISTENCY IN SINGULAR CASE C --------------------------------------- C PERTRB = 0.0E0 IF (SNGULR) THEN SCALE = 0.0E0 DO 100 J=JL,JR FY = 1.0E0 IF (.NOT.PRDY.AND.(J.NE.1).AND.(J.NE.NY)) FY = 2.0E0 DO 100 I=IL,IR FX = 1.0E0 IF (.NOT.PRDX.AND.(I.NE.1).AND.(I.NE.NX)) FX = 2.0E0 FACTOR = FX*FY PERTRB = PERTRB + FACTOR*U(I,J) SCALE = SCALE + FACTOR 100 CONTINUE PERTRB = -PERTRB/SCALE DO 110 J=JL,JR DO 110 I=IL,IR U(I,J) = U(I,J) + PERTRB 110 CONTINUE ENDIF C C C ------------------------------ C MATRIX DECOMPOSITION USING FFT C ------------------------------ C CALL MDALG2(A,B,C,BCTY,U,LDXU,IL,IR,JL,JR,WORK) C C C ----------------------------------------- C SELECT MIN NORM SOLUTION IN SINGULAR CASE C ----------------------------------------- C IF (SNGULR) THEN UNORM = 0.0E0 DO 210 J=JL,JR DO 210 I=IL,IR UNORM = UNORM + U(I,J) 210 CONTINUE UNORM = UNORM/REAL(NM) DO 220 J=JL,JR DO 220 I=IL,IR U(I,J) = U(I,J) - UNORM 220 CONTINUE ENDIF C C C -------------------------------------- C COPY IDENTICAL LINES IN PERIODIC CASES C -------------------------------------- C IF (PRDX) THEN DO 325 J=1,NY U(NX,J) = U(1,J) 325 CONTINUE ENDIF C IF (PRDY) THEN DO 375 I=1,NX U(I,NY) = U(I,1) 375 CONTINUE ENDIF C C C ----------- C NORMAL EXIT C ----------- C WORK(1) = PERTRB GO TO 999 C C C ----------- C ERROR EXITS C ----------- C 901 CONTINUE INFO = -1 GO TO 999 C 902 CONTINUE INFO = -2 GO TO 999 C 903 CONTINUE INFO = -3 GO TO 999 C 904 CONTINUE INFO = -4 GO TO 999 C 905 CONTINUE INFO = -5 GO TO 999 C 906 CONTINUE INFO = -6 GO TO 999 C 907 CONTINUE INFO = -7 GO TO 999 C 908 CONTINUE INFO = -8 GO TO 999 C 999 CONTINUE RETURN END SUBROUTINE EVDISC (KBCL, KBCR, EIGEN, N) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C EVDISC COMPUTES THE EIGENVALUES OF THE FOLLOWING MATRIX C C :-- --: C : 0 R T : C : 1 0 1 : C : 1 0 1 : C : . . . : C : . . . : C : 1 0 1 : C : 1 0 1 : C : T S 0 : C :-- --: C C WHERE THE SCALARS R, S, AND T DEPEND UPON THE PARAMETERS KBCL C AND KBCR IN THE FOLLOWING WAY. C C R = 1 (UNLESS KBCL=2 IN WHICH CASE R=2) C S = 1 (UNLESS KBCR=2 IN WHICH CASE S=2) C T = 0 (UNLESS KBCR=3 IN WHICH CASE T=1) C C C P A R A M E T E R S C ------------------- C C KBCL, KBCR INTEGER SCALARS (INPUT) C INDICATE THE TYPE OF BOUNDARY CONDITIONS AT C THE LEFT AND RIGHT ENDS OF AN INTERVAL. C USES SAME CONVENTIONS AS BCTY IN HFFT2A. C C EIGEN REAL ARRAY OF SIZE N (OUTPUT) C THE EIGENVALUES OF THE MATRIX SHOWN ABOVE. C C N INTEGER SCALAR (INPUT) C THE ORDER OF THE MATRIX. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER KBCL, KBCR, N REAL * EIGEN(N) C C ... LOCAL VARIABLES C REAL * PI, FACTOR C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C PI = 4.0E0*ATAN(1.0E0) C C ----------- C SELECT CASE C ----------- C GO TO (10,20,30), KBCL 10 GO TO (100,200), KBCR 20 GO TO (200,300), KBCR 30 GO TO 400 C C CASE : DIRICHLET/DIRICHLET C 100 CONTINUE FACTOR = PI/REAL(N+1) DO 110 I=1,N EIGEN(I) = 2.0E0*COS(REAL(I)*FACTOR) 110 CONTINUE GO TO 500 C C CASE : DIRICHLET/NEUMANN C 200 CONTINUE FACTOR = PI/REAL(2*N) DO 210 I=1,N EIGEN(I) = 2.0E0*COS(REAL(2*I-1)*FACTOR) 210 CONTINUE GO TO 500 C C CASE : NEUMANN/NEUMANN C 300 CONTINUE FACTOR = PI/REAL(N-1) DO 310 I=1,N EIGEN(I) = 2.0E0*COS(REAL(I-1)*FACTOR) 310 CONTINUE GO TO 500 C C CASE : PERIODIC C 400 CONTINUE FACTOR = 2.0E0*PI/REAL(N) DO 410 I=1,N K = I/2 EIGEN(I) = 2.0E0*COS(REAL(K)*FACTOR) 410 CONTINUE GO TO 500 C C ---- C EXIT C ---- C 500 CONTINUE RETURN END SUBROUTINE FDIS2 (NX, NY, H, COEFU, BCTY, BD1, BD2, BD3, BD4, * A, B, C, U, LDXU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FDIS2 COMPUTES A SECOND ORDER FINITE DIFFERENCE DISCRETIZATION C FOR A TWO-DIMENSIONAL RECTANGULAR DOMAIN C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C H, COEFU REAL SCALARS (INPUT) C SEE HFFT2A. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C BD1, BD3 REAL ARRAYS OF SIZE NY (INPUT) C SEE HFFT2A. C C BD2, BD4 REAL ARRAYS OF SIZE NX (INPUT) C SEE HFFT2A. C C A, B, C REAL SCALARS (OUTPUT) C GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL C (SCALED TO O(1)) C C C B C C B A B U = RIGHT SIDE C C B C C C U REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT) C ON INPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE PDE C EVALUATED AT THE (I,J)TH GRID POINT. C ON OUTPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE C DISCRETE PDE AT THE (I,J)TH GRID POINT. C C LDXU INTEGER SCALAR (INPUT) C SEE HFFT2A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY, LDXU REAL * BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY), * COEFU, H, A, B, C C C ... LOCAL VARIABLES C LOGICAL HAVED, HAVEN INTEGER I, J, NXM1, NYM1 REAL * BETA0, GAMMA0, DELTA0, DELTA1, H2, F C COMMON /FD2COM/ GAMMA0, DELTA0, DELTA1 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 C HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR. * (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP ) .EQ. DRCH) HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR. * (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP ) .EQ. NEUM) C H2 = H*H F = -H2*COEFU A = -(20.0E0 + 6.0E0*F) B = 4.0E0 C = 1.0E0 BETA0 = 6.0E0*H2 GAMMA0 = -12.0E0*H DELTA0 = -10.0E0*H DELTA1 = -2.0E0*H C C C --------------------------------- C DISCRETIZE RIGHT HAND SIDE OF PDE C --------------------------------- C ISTRT = 2 ISTOP = NXM1 IF (BCTY(LEFT ) .NE. DRCH) ISTRT = 1 IF (BCTY(RIGH T) .EQ. NEUM) ISTOP = NX JSTRT = 2 JSTOP = NYM1 IF (BCTY(BOTTOM) .NE. DRCH) JSTRT = 1 IF (BCTY(TOP ) .EQ. NEUM) JSTOP = NY C DO 100 J=JSTRT,JSTOP DO 100 I=ISTRT,ISTOP U(I,J) = BETA0*U(I,J) 100 CONTINUE C C --------------------------------------- C DISCRETIZE POINTS ON NEUMANN BOUNDARIES C --------------------------------------- C IF (HAVEN) CALL FD2N(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU) C C ---------------------------------------------- C ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES C ---------------------------------------------- C IF (HAVED) THEN CALL STORD2(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU) CALL FD2D(NX,NY,U,LDXU,BCTY,B,C,U) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FD2D (NX, NY, UD, LDXU, BCTY, B, C, U) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FD2D ELIMINATES KNOWN TERMS FROM EQUATIONS CORRESPONDING TO POINTS C NEAR DIRICHLET BOUNDARIES OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN. C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C UD REAL ARRAY OF SIZE LDXU BY NY (INPUT) C ENTRIES CORRESPONDING TO DIRICHLET POINTS CONTAIN C KNOWN VALUES OF THE SOLUTION. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY C AS DECLARED IN THE CALLING PROGRAM. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C B, C REAL SCALARS (INPUT) C FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE C ELIMINATION C C C B C C B * B C C B C C C U REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT) C ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE C SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND C SIDE OF A FINITE DIFFERENCE DISCRETIZATION. C ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT KNOWN C TERMS (DIRICHLET POINTS) ARE ELIMINATED FROM THE C LEFT HAND SIDE OF THE EQUATION. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY REAL * UD(LDXU,NY), U(LDXU,NY), B, C C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY INTEGER I, J, NXM1, NXM2, NYM1, NYM2 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NXM2 = NX - 2 NYM2 = NY - 2 PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C C C ----------------------------------------------- C ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES C ----------------------------------------------- C IL = 2 IR = NXM1 JL = 2 JR = NYM1 IF (BCTY(LEFT ) .EQ. DRCH) IL = 3 IF (BCTY(RIGHT ) .EQ. DRCH) IR = NXM2 IF (BCTY(BOTTOM) .EQ. DRCH) JL = 3 IF (BCTY(TOP ) .EQ. DRCH) JR = NYM2 C C ... INTERIOR POINTS NEAR BOTTOM EDGE C IF (BCTY(BOTTOM) .EQ. DRCH) THEN DO 505 I=IL,IR U(I,2) = U(I,2) - (C*UD(I-1,1)+B*UD(I,1)+C*UD(I+1,1)) 505 CONTINUE ENDIF C C ... INTERIOR POINTS NEAR TOP EDGE C IF (BCTY(TOP) .EQ. DRCH) THEN DO 515 I=IL,IR U(I,NYM1)= U(I,NYM1) -(C*UD(I-1,NY)+B*UD(I,NY)+C*UD(I+1,NY)) 515 CONTINUE ENDIF C C ... INTERIOR POINTS NEAR LEFT EDGE C IF (BCTY(LEFT) .EQ. DRCH) THEN DO 525 J=JL,JR U(2,J) = U(2,J) - (C*UD(1,J-1)+B*UD(1,J)+C*UD(1,J+1)) 525 CONTINUE ENDIF C C ... INTERIOR POINTS NEAR RIGHT EDGE C IF (BCTY(RIGHT) .EQ. DRCH) THEN DO 535 J=JL,JR U(NXM1,J)= U(NXM1,J) -(C*UD(NX,J-1)+B*UD(NX,J)+C*UD(NX,J+1)) 535 CONTINUE ENDIF C C ... INTERIOR POINTS NEAR CORNERS C IF ((BCTY(RIGHT) .EQ. DRCH) .AND. (BCTY(BOTTOM) .EQ. DRCH)) * U(NXM1,2) = U(NXM1,2) - B*(UD(NX,2) + UD(NXM1,1)) * - C*(UD(NX,3) + UD(NX,1) + UD(NXM2,1)) C IF ((BCTY(BOTTOM) .EQ. DRCH) .AND. (BCTY(LEFT) .EQ. DRCH)) * U(2,2) = U(2,2) - B*(UD(1,2) + UD(2,1)) * - C*(UD(1,3) + UD(1,1) + UD(3,1)) C IF ((BCTY(LEFT) .EQ. DRCH) .AND. (BCTY(TOP) .EQ. DRCH)) * U(2,NYM1) = U(2,NYM1) - B*(UD(1,NYM1) + UD(2,NY)) * - C*(UD(1,NYM2) + UD(1,NY) + UD(3,NY)) C IF ((BCTY(TOP) .EQ. DRCH) .AND. (BCTY(RIGHT) .EQ. DRCH)) * U(NXM1,NYM1) = U(NXM1,NYM1) - B*(UD(NXM1,NY) + UD(NX,NYM1)) * - C*(UD(NXM2,NY)+UD(NX,NY)+UD(NX,NYM2)) C C ... NEUMANN POINTS NEAR CORNERS ON BOTTOM EDGE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN IF (BCTY(LEFT) .EQ. DRCH) * U(2,1) = U(2,1) - (B*UD(1,1) + 2.0E0*C*UD(1,2)) IF (BCTY(RIGHT) .EQ. DRCH) * U(NXM1,1) = U(NXM1,1) - (B*UD(NX,1) + 2.0E0*C*UD(NX,2)) ENDIF C C ... NEUMANN POINTS NEAR CORNERS ON TOP EDGE C IF (BCTY(TOP) .EQ. NEUM) THEN IF (BCTY(LEFT) .EQ. DRCH) * U(2,NY) = U(2,NY) - (B*UD(1,NY) + 2.0E0*C*UD(1,NYM1)) IF (BCTY(RIGHT) .EQ. DRCH) * U(NXM1,NY)= U(NXM1,NY) - (B*UD(NX,NY) + 2.0E0*C*UD(NX,NYM1)) ENDIF C C ... NEUMANN POINTS NEAR CORNERS ON LEFT EDGE C IF (BCTY(LEFT) .EQ. NEUM) THEN IF (BCTY(BOTTOM) .EQ. DRCH) * U(1,2) = U(1,2) - (B*UD(1,1) + 2.0E0*C*UD(2,1)) IF (BCTY(TOP) .EQ. DRCH) * U(1,NYM1) = U(1,NYM1) - (B*UD(1,NY) + 2.0E0*C*UD(2,NY)) ENDIF C C ... NEUMANN POINTS NEAR CORNERS ON RIGHT EDGE C IF (BCTY(RIGHT) .EQ. NEUM) THEN IF (BCTY(BOTTOM) .EQ. DRCH) * U(NX,2) = U(NX,2) - (B*UD(NX,1) + 2.0E0*C*UD(NXM1,1)) IF (BCTY(TOP) .EQ. DRCH) * U(NX,NYM1)= U(NX,NYM1) - (B*UD(NX,NY) + 2.0E0*C*UD(NXM1,NY)) ENDIF C C ... PERIODIC POINTS ON LEFT EDGE C IF (PRDX) THEN IF (BCTY(BOTTOM) .EQ. DRCH) * U(1,2) = U(1,2) - (C*UD(NXM1,1) + B*UD(1,1) + C*UD(2,1)) IF (BCTY(TOP) .EQ. DRCH) * U(1,NYM1)= U(1,NYM1) - (C*UD(NXM1,NY)+B*UD(1,NY)+C*UD(2,NY)) ENDIF C C ... PERIODIC POINTS ON BOTTOM EDGE C IF (PRDY) THEN IF (BCTY(LEFT) .EQ. DRCH) * U(2,1) = U(2,1) - (C*UD(1,NYM1) + B*UD(1,1) + C*UD(1,2)) IF (BCTY(RIGHT) .EQ. DRCH) * U(NXM1,1)= U(NXM1,1) - (C*UD(NX,NYM1)+B*UD(NX,1)+C*UD(NX,2)) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FD2N (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FD2N COMPUTES THE SECOND ORDER FINITE DIFFERENCE DISCRETIZATION C AT ALL BOUNDARY POINTS OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN C WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED. C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C BD1, BD3 INTEGER ARRAYS OF SIZE NY (INPUT) C SEE HFFT2A. C C BD2, BD4 INTEGER ARRAYS OF SIZE NX (INPUT) C SEE HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY NY (OUTPUT) C ON EXIT, ENTRIES OF U CORRESPONDING TO NEUMANN BOUNDARY C POINTS CONTAIN THE RIGHT HAND SIDE OF THE SECOND ORDER C FINITE DIFFERENCE DISCRETIZATION C C LDXU INTEGER SCALAR (INPUT) C SEE HFFT2A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY, LDXU REAL * BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY) C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY INTEGER I, J, NXM1, NYM1 REAL * GAMMA0, DELTA0, DELTA1 C COMMON /FD2COM/ GAMMA0, DELTA0, DELTA1 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C C C ----------------------------- C NEUMANN POINT DISCRETIZATIONS C ----------------------------- C C ... BOTTOM EDGE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN DO 305 I=2,NXM1 U(I,1) = U(I,1) - GAMMA0*BD2(I) 305 CONTINUE ENDIF C C ... TOP EDGE C IF (BCTY(TOP) .EQ. NEUM) THEN DO 315 I=2,NXM1 U(I,NY) = U(I,NY) + GAMMA0*BD4(I) 315 CONTINUE ENDIF C C ... LEFT EDGE C IF (BCTY(LEFT) .EQ. NEUM) THEN DO 325 J=2,NYM1 U(1,J) = U(1,J) - GAMMA0*BD3(J) 325 CONTINUE ENDIF C C ... RIGHT EDGE C IF (BCTY(RIGHT) .EQ. NEUM) THEN DO 335 J=2,NYM1 U(NX,J) = U(NX,J) + GAMMA0*BD1(J) 335 CONTINUE ENDIF C C ... LOWER RIGHT CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(NX,1) = U(NX,1) * + DELTA0*BD1(1) * + DELTA1*BD1(2) * - DELTA0*BD2(NX) * - DELTA1*BD2(NXM1) C C ... LOWER LEFT CORNER C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM)) * U(1,1) = U(1,1) * - DELTA0*BD2(1) * - DELTA1*BD2(2) * - DELTA0*BD3(1) * - DELTA1*BD3(2) C C ... UPPER LEFT CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) * U(1,NY) = U(1,NY) * - DELTA0*BD3(NY) * - DELTA1*BD3(NYM1) * + DELTA0*BD4(1) * + DELTA1*BD4(2) C C ... UPPER RIGHT CORNER C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM)) * U(NX,NY) = U(NX,NY) * + DELTA0*BD1(NY) * + DELTA1*BD1(NYM1) * + DELTA0*BD4(NX) * + DELTA1*BD4(NXM1) C C C ----------------------------- C PERIODIC POINT DISCRETIZATION C ----------------------------- C C ... LOWER LEFT CORNER (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(1,1) = U(1,1) - GAMMA0*BD2(1) C C ... LOWER LEFT CORNER (NEUMANN/PERIODIC) C IF (PRDY .AND. (BCTY(LEFT) .EQ. NEUM)) * U(1,1) = U(1,1) - GAMMA0*BD3(1) C C ... UPPER LEFT CORNER (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) * U(1,NY) = U(1,NY) + GAMMA0*BD4(1) C C ... LOWER RIGHT CORNER (NEUMANN/PERIODIC) C IF (PRDY .AND. (BCTY(RIGHT) .EQ. NEUM)) * U(NX,1) = U(NX,1) + GAMMA0*BD1(1) C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FFTB (KBCL, KBCR, U, LDXU, IL, IR, JL, JR, WSAVE) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FFTB PERFORMS M=JR-JL+1 REAL ONE-DIMENSIONAL INVERSE DISCRETE C FOURIER TRANSFORMS OF LENGTH N=IR-IL+1 (FOURIER SYNTHESIS). C THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS. C C C P A R A M E T E R S C ------------------- C C KBCL, KBCR INTEGER SCALARS (INPUT) C GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND C RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE C THE SAME AS IN THE VECTOR BCTY OF HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT) C ON INPUT, U CONTAINS THE SEQUENCES TO BE TRANSFORMED C IN COLUMNS JL TO JR. WITHIN EACH COLUMN THE C SEQUENCES ARE STORED IN POSITIONS IL TO IR. C ON OUTPUT THESE VALUES ARE REPLACED BY THEIR DISCRETE C FOURIER TRANSFORMS. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C IL, IR INTEGER SCALARS (INPUT) C JL, JR GIVES THE SUBSET OF THE ARRAY U WHICH CONTAINS THE C SEQUENCES TO BE TRANSFORMED, I.E., POSITIONS I= C IL,..,IR OF COLUMNS J=JL,..,JR. C C WSAVE REAL ARRAY OF SIZE 3*N + N/2 + 15 (INPUT) C THE WORK ARRAY EXACTLY AS RETURNED FROM THE ROUTINE C FFTI. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER KBCL, KBCR, IL, IR, JL, JR REAL * U(LDXU,*), WSAVE(*) C C ... LOCAL VARIABLES C INTEGER ICASE REAL * SCALE C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C N = IR - IL + 1 C C --------------------------------------------- C SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS C --------------------------------------------- C ICASE = 2*(KBCL-1) + KBCR IF (KBCL .EQ. PRDC) ICASE = 5 GO TO (100,200,300,400,500), ICASE C C CASE : DIRICHLET/DIRICHLET C 100 CONTINUE SCALE = 0.50E0/REAL(N+1) DO 150 J=JL,JR CALL SINT(N,U(IL,J),WSAVE) 150 CONTINUE GO TO 600 C C CASE : DIRICHLET/NEUMANN C 200 CONTINUE SCALE = 0.250E0/REAL(N) DO 250 J=JL,JR CALL SINQB(N,U(IL,J),WSAVE) 250 CONTINUE GO TO 600 C C CASE : NEUMANN/DIRICHLET C 300 CONTINUE SCALE = 0.250E0/REAL(N) DO 350 J=JL,JR CALL COSQB(N,U(IL,J),WSAVE) 350 CONTINUE GO TO 600 C C CASE : NEUMANN/NEUMANN C 400 CONTINUE SCALE = 0.50E0/REAL(N-1) DO 450 J=JL,JR CALL COST(N,U(IL,J),WSAVE) 450 CONTINUE GO TO 600 C C CASE : PERIODIC C 500 CONTINUE SCALE = 1.0E0/REAL(N) DO 550 J=JL,JR CALL RFFTB(N,U(IL,J),WSAVE) 550 CONTINUE C C ----------------------------------- C SCALE RESULT TO GET CORRECT INVERSE C ----------------------------------- C 600 CONTINUE DO 650 J=JL,JR DO 650 I=IL,IR U(I,J) = SCALE*U(I,J) 650 CONTINUE C C C ---- C EXIT C ---- C RETURN END SUBROUTINE FFTF (KBCL, KBCR, U, LDXU, IL, IR, JL, JR, WSAVE) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FFTF PERFORMS M=JR-JL+1 REAL ONE-DIMENSIONAL DISCRETE FOURIER C TRANSFORMS OF LENGTH N=IR-IL+1 (FOURIER ANALYSIS). C THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS. C C C P A R A M E T E R S C ------------------- C C KBCL, KBCR INTEGER SCALARS (INPUT) C GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND C RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE C THE SAME AS IN THE VECTOR BCTY OF HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT) C ON INPUT, U CONTAINS THE SEQUENCES TO BE TRANSFORMED C IN COLUMNS JL TO JR. WITHIN EACH COLUMN THE C SEQUENCES ARE STORED IN POSITIONS IL TO IR. C ON OUTPUT THESE VALUES ARE REPLACED BY THEIR DISCRETE C FOURIER TRANSFORMS. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C IL, IR INTEGER SCALARS (INPUT) C JL, JR GIVES THE SUBSET OF THE ARRAY U WHICH CONTAINS THE C SEQUENCES TO BE TRANSFORMED, I.E., POSITIONS I= C IL,..,IR OF COLUMNS J=JL,..,JR. C C WSAVE REAL ARRAY OF SIZE 3*N + N/2 + 15 (INPUT) C THE WORK ARRAY EXACTLY AS RETURNED FROM THE ROUTINE C FFTI. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER KBCL, KBCR, IL, IR, JL, JR REAL * U(LDXU,*), WSAVE(*) C C ... LOCAL VARIABLES C INTEGER ICASE C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C N = IR - IL + 1 C C --------------------------------------------- C SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS C --------------------------------------------- C ICASE = 2*(KBCL-1) + KBCR IF (KBCL .EQ. PRDC) ICASE = 5 GO TO (100,200,300,400,500), ICASE C C CASE : DIRICHLET/DIRICHLET C 100 CONTINUE DO 150 J=JL,JR CALL SINT(N,U(IL,J),WSAVE) 150 CONTINUE GO TO 600 C C CASE : DIRICHLET/NEUMANN C 200 CONTINUE DO 250 J=JL,JR CALL SINQF(N,U(IL,J),WSAVE) 250 CONTINUE GO TO 600 C C CASE : NEUMANN/DIRICHLET C 300 CONTINUE DO 350 J=JL,JR CALL COSQF(N,U(IL,J),WSAVE) 350 CONTINUE GO TO 600 C C CASE : NEUMANN/NEUMANN C 400 CONTINUE DO 450 J=JL,JR CALL COST(N,U(IL,J),WSAVE) 450 CONTINUE GO TO 600 C C CASE : PERIODIC C 500 CONTINUE DO 550 J=JL,JR CALL RFFTF(N,U(IL,J),WSAVE) 550 CONTINUE C C C ---- C EXIT C ---- C 600 CONTINUE RETURN END SUBROUTINE FFTI (KBCL, KBCR, N, WSAVE) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C FFTI INITIALIZES THE ONE-DIMENSIONAL FOURIER TRANSFORM SOFTWARE. C THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS. C C C P A R A M E T E R S C ------------------- C C KBCL, KBCR INTEGER SCALARS (INPUT) C GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND C RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE C THE SAME AS IN THE VECTOR BCTY OF HFFT2A. C C N INTEGER SCALAR (INPUT) C THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. C C WSAVE REAL ARRAY OF SIZE 3*N + N/2 + 15 (OUTPUT) C CONTAINS INFORMATION WHICH MUST BE PASSED TO THE C SUBROUTINES FFTF AND FFTB WHEN ACTUALLY PERFORMING C THE TRANSFORMS. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER KBCL, KBCR, N REAL * WSAVE(*) C C ... LOCAL VARIABLES C INTEGER ICASE C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------------------------------------- C SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS C --------------------------------------------- C ICASE = 2*(KBCL-1) + KBCR IF (KBCL .EQ. PRDC) ICASE = 5 GO TO (110,120,130,140,150), ICASE C C CASE : DIRICHLET/DIRICHLET C 110 CONTINUE CALL SINTI(N,WSAVE) GO TO 200 C C CASE : DIRICHLET/NEUMANN C 120 CONTINUE CALL SINQI(N,WSAVE) GO TO 200 C C CASE : NEUMANN/DIRICHLET C 130 CONTINUE CALL COSQI(N,WSAVE) GO TO 200 C C CASE : NEUMANN/NEUMANN C 140 CONTINUE CALL COSTI(N,WSAVE) GO TO 200 C C CASE : PERIODIC C 150 CONTINUE CALL RFFTI(N,WSAVE) GO TO 200 C C C ---- C EXIT C ---- C 200 CONTINUE RETURN END SUBROUTINE HDIS2 (NX, NY, H, COEFU, GH, LMXGH, BCTY, * BD1, BD2, BD3, BD4, A, B, C, U, LMXU, WORK) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C HDIS2 COMPUTES A FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION C FOR A TWO-DIMENSIONAL RECTANGULAR DOMAIN C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C H, COEFU REAL SCALARS (INPUT) C SEE HFFT2A. C C GH REAL ARRAY OF SIZE LMXGH+1 BY NY+1 (INPUT) C SEE HFFT2A. C C LMXGH INTEGER SCALAR (INPUT) C UPPER LIMIT OF FIRST DIMENSION OF ARRAY GH. MUST BE C LDXGH-1 (LDXGH IS DEFINED IN HFFT2A). C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C BD1, BD3 REAL ARRAYS OF SIZE NY (INPUT) C SEE HFFT2A. C C BD2, BD4 REAL ARRAYS OF SIZE NX (INPUT) C SEE HFFT2A. C C A, B, C REAL SCALARS (OUTPUT) C GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL C (SCALED TO O(1)) C C C B C C B A B U = RIGHT SIDE C C B C C C U REAL ARRAY OF SIZE LMXU+1 BY NY+2 (INPUT/OUTPUT) C ON INPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE PDE C EVALUATED AT THE (I,J)TH GRID POINT. C ON OUTPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE C DISCRETE PDE AT THE (I,J)TH GRID POINT. C C LMXU INTEGER SCALAR (INPUT) C UPPER LIMIT OF FIRST DIMENSION OF ARRAY U. MUST BE C LDXU-1 (LDXU IS DEFINED IN HFFT2A). C C WORK REAL ARRAY OF SIZE NX+1 BY 2 C WORKING STORAGE FOR HDIS2. C C C ****************************************************************** C * * C * NOTE -- THE ARRAYS U AND GH ARE INDEXED DIFFERENTLY IN * C * THIS ROUTINE: U(0:LMXU,0:*) AND GH(0:LMXGH,0:*) * C * * C ****************************************************************** C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY, LMXGH, LMXU REAL * BD1(NY), BD2(NX), BD3(NY), BD4(NX), * GH(0:LMXGH,0:*), U(0:LMXU,0:*), WORK(0:NX,0:1), * COEFU, H, A, B, C C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY, HELMHZ, HAVED, HAVEN INTEGER I, J, JM1, NXM1, NYM1, C0, CM1 REAL * BETA0, BETA1, BETA2, DELTA0, DELTA1, DELTA2, * DELTA3, GAMMA0, GAMMA1, H2, F, F2 C COMMON /HD2COM/ GAMMA0, GAMMA1, DELTA0, DELTA1, DELTA2, DELTA3 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C LDXU = LMXU + 1 NXM1 = NX - 1 NYM1 = NY - 1 C HELMHZ = COEFU .NE. 0.0E0 HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR. * (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP ) .EQ. DRCH) HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR. * (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP ) .EQ. NEUM) PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C H2 = H*H F = -H2*COEFU F2 = F*F A = -(480.0E0 + 118.0E0*F + 5.0E0*F2)/24.0E0 B = (192.0E0 - 8.0E0*F + F2)/48.0E0 C = ( 48.0E0 - 5.0E0*F)/48.0E0 BETA0 = (48.0E0 + 5.0E0*F)/24.0E0 BETA1 = -F/48.0E0 BETA2 = 1.0E0 GAMMA0 = -(12.0E0 + 13.0E0*F/12.0E0) GAMMA1 = -F/12.0E0 DELTA2 = 2.0E0 + F/48.0E0 DELTA3 = ((6.0E0 + F)/3.0E0 - 4.0E0*DELTA2)/18.0E0 DELTA1 = 8.0E0*DELTA2 + 33.0E0*DELTA3 - (10.0E0 + F)*BETA2 DELTA0 = -2.0E0*(BETA0 + 2.0E0*BETA1) - (DELTA2 + 4.0E0*DELTA3) * - (4.0E0 + F*0.50E0)*BETA2 C BETA0 = H2*BETA0 BETA1 = H2*BETA1 BETA2 = H2*BETA2 GAMMA0 = H*GAMMA0 GAMMA1 = H*GAMMA1 DELTA0 = H*DELTA0 DELTA1 = H*DELTA1 DELTA2 = H*DELTA2 DELTA3 = H*DELTA3 C C C ----------------------------- C SHIFT VALUES OF G STORED IN U C ----------------------------- C DO 50 J=NY,1,-1 DO 50 I=NX,1,-1 U(I,J) = U(I-1,J-1) 50 CONTINUE C C C ----------------------------------------- C REFLECT FUNCTIONS G AND GH OUTSIDE DOMAIN C ----------------------------------------- C IF (HELMHZ) CALL REFL2(1,NX,NY,PRDX,PRDY,U,LMXU) CALL REFL2(0,NXM1,NYM1,PRDX,PRDY,GH,LMXGH) C C C ---------------------------- C DISCRETIZE RIGHT SIDE OF PDE C ---------------------------- C ISTRT = 2 ISTOP = NXM1 IF (BCTY(LEFT ) .NE. DRCH) ISTRT = 1 IF (BCTY(RIGHT ) .EQ. NEUM) ISTOP = NX JSTRT = 2 JSTOP = NYM1 IF (BCTY(BOTTOM) .NE. DRCH) JSTRT = 1 IF (BCTY(TOP ) .EQ. NEUM) JSTOP = NY C IF (HELMHZ) THEN C C CASE : HELMHOLTZ EQUATION C C0 = 0 JM1 = JSTRT - 1 DO 60 I=0,NX WORK(I,C0) = U(I,JM1) 60 CONTINUE DO 100 J=JSTRT,JSTOP CM1 = C0 C0 = 1 - CM1 DO 80 I=0,NX WORK(I,C0) = U(I,J) 80 CONTINUE DO 100 I=ISTRT,ISTOP U(I,J) = BETA0*U(I,J) * + BETA1*( U(I+1,J) + U(I,J+1) * + WORK(I,CM1) + WORK(I-1,C0) ) * + BETA2*( GH(I,J) + GH(I-1,J) + * GH(I-1,J-1) + GH(I,J-1) ) 100 CONTINUE C ELSE C C CASE : POISSON EQUATION C DO 200 J=JSTRT,JSTOP DO 200 I=ISTRT,ISTOP U(I,J) = BETA0*U(I,J) * + BETA2*( GH(I,J) + GH(I-1,J) + * GH(I-1,J-1) + GH(I,J-1) ) 200 CONTINUE C ENDIF C C C ------------------------- C REMOVE SHIFT FROM ARRAY U C ------------------------- C DO 250 J=0,NYM1 DO 250 I=0,NXM1 U(I,J) = U(I+1,J+1) 250 CONTINUE C C C --------------------------------------- C DISCRETIZE POINTS ON NEUMANN BOUNDARIES C --------------------------------------- C IF (HAVEN) CALL HD2N(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU) C C C ----------------------------------------------- C ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES C ----------------------------------------------- C IF (HAVED) THEN CALL STORD2(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU) CALL FD2D(NX,NY,U,LDXU,BCTY,B,C,U) ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE HD2N (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C HD2N COMPUTES THE FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION C AT ALL BOUNDARY POINTS OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN C WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED. C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C BD1, BD3 INTEGER ARRAYS OF SIZE NY (INPUT) C SEE HFFT2A. C C BD2, BD4 INTEGER ARRAYS OF SIZE NX (INPUT) C SEE HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY NY (OUTPUT) C ON EXIT, ENTRIES CORRESPONDING TO NEUMANN BOUNDARY C POINTS CONTAIN THE RIGHT HAND SIDE OF THE FINITE C DIFFERENCE DISCRETIZTION C C LDXU INTEGER SCALAR (INPUT) C SEE HFFT2A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), NX, NY, LDXU REAL * BD1(NY), BD2(NX), BD3(NY), BD4(NX), * U(LDXU,NY) C C ... LOCAL VARIABLES C LOGICAL PRDX, PRDY INTEGER I, J, NXM1, NYM1 REAL * DELTA0, DELTA1, DELTA2, DELTA3, GAMMA0, GAMMA1 C COMMON /HD2COM/ GAMMA0, GAMMA1, DELTA0, DELTA1, DELTA2, DELTA3 C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C NXM1 = NX - 1 NYM1 = NY - 1 NXM2 = NX - 2 NYM2 = NY - 2 NXM3 = NX - 3 NYM3 = NY - 3 PRDX = BCTY(RIGHT ) .EQ. PRDC PRDY = BCTY(BOTTOM) .EQ. PRDC C C C ---------------------------- C NEUMANN POINT DISCRETIZATION C ---------------------------- C C ... BOTTOM EDGE C IF (BCTY(BOTTOM) .EQ. NEUM) THEN DO 305 I=2,NXM1 U(I,1) = U(I,1) * - GAMMA0*BD2(I) * - GAMMA1*(BD2(I-1) + BD2(I+1)) 305 CONTINUE ENDIF C C ... TOP EDGE C IF (BCTY(TOP) .EQ. NEUM) THEN DO 315 I=2,NXM1 U(I,NY) = U(I,NY) * + GAMMA0*BD4(I) * + GAMMA1*(BD4(I-1)+BD4(I+1)) 315 CONTINUE ENDIF C C ... LEFT EDGE C IF (BCTY(LEFT) .EQ. NEUM) THEN DO 325 J=2,NYM1 U(1,J) = U(1,J) * - GAMMA0*BD3(J) * - GAMMA1*(BD3(J-1) + BD3(J+1)) 325 CONTINUE ENDIF C C ... RIGHT EDGE C IF (BCTY(RIGHT) .EQ. NEUM) THEN DO 335 J=2,NYM1 U(NX,J) = U(NX,J) * + GAMMA0*BD1(J) * + GAMMA1*(BD1(J-1) + BD1(J+1)) 335 CONTINUE ENDIF C C ... LOWER RIGHT CORNER C IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(NX,1) = U(NX,1) * + DELTA0*BD1(1) * + DELTA1*BD1(2) * + DELTA2*BD1(3) * + DELTA3*BD1(4) * - DELTA0*BD2(NX) * - DELTA1*BD2(NXM1) * - DELTA2*BD2(NXM2) * - DELTA3*BD2(NXM3) C C ... LOWER LEFT CORNER C IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM)) * U(1,1) = U(1,1) * - DELTA0*BD2(1) * - DELTA1*BD2(2) * - DELTA2*BD2(3) * - DELTA3*BD2(4) * - DELTA0*BD3(1) * - DELTA1*BD3(2) * - DELTA2*BD3(3) * - DELTA3*BD3(4) C C ... UPPER LEFT CORNER C IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) * U(1,NY) = U(1,NY) * - DELTA0*BD3(NY) * - DELTA1*BD3(NYM1) * - DELTA2*BD3(NYM2) * - DELTA3*BD3(NYM3) * + DELTA0*BD4(1) * + DELTA1*BD4(2) * + DELTA2*BD4(3) * + DELTA3*BD4(4) C C ... UPPER RIGHT CORNER C IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM)) * U(NX,NY) = U(NX,NY) * + DELTA0*BD1(NY) * + DELTA1*BD1(NYM1) * + DELTA2*BD1(NYM2) * + DELTA3*BD1(NYM3) * + DELTA0*BD4(NX) * + DELTA1*BD4(NXM1) * + DELTA2*BD4(NXM2) * + DELTA3*BD4(NXM3) C C IF (.NOT. (PRDX .OR. PRDY)) GO TO 999 C C C ------------------------------------- C NEUMANN/PERIODIC POINT DISCRETIZATION C ------------------------------------- C C ... LOWER LEFT CORNER (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM)) * U(1,1) = U(1,1) * - GAMMA0*BD2(1) * - GAMMA1*(BD2(2) + BD2(NXM1)) C C ... LOWER LEFT CORNER (NEUMANN/PERIODIC) C IF (PRDY .AND. (BCTY(LEFT) .EQ. NEUM)) * U(1,1) = U(1,1) * - GAMMA0*BD3(1) * - GAMMA1*(BD3(2) + BD3(NYM1)) C C ... UPPER LEFT CORNER (PERIODIC/NEUMANN) C IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) * U(1,NY) = U(1,NY) * + GAMMA0*BD4(1) * + GAMMA1*(BD4(2) + BD4(NXM1)) C C ... LOWER RIGHT CORNER (NEUMANN/PERIODIC) C IF (PRDY .AND. (BCTY(RIGHT) .EQ. NEUM)) * U(NX,1) = U(NX,1) * + GAMMA0*BD1(1) * + GAMMA1*(BD1(2) + BD1(NYM1)) C C ---- C EXIT C ---- C 999 CONTINUE RETURN END SUBROUTINE MDALG2 (A, B, C, BCTY, U, LDXU, IL, IR, JL, JR, WORK) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C C DECEMBER 1985 (REVISED APRIL 1987) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C MDALG2 IMPLEMENTS THE MATRIX DECOMPOSITION ALGORITHM (FOURIER C METHOD FOR A NINE-POINT DIFFERENCE OPERATOR ON A TWO-DIMENSIONAL C RECTANGULAR GRID. C C C P A R A M E T E R S C ------------------- C C A, B, C REAL SCALARS (INPUT) C GIVE THE BASIC FINITE DIFFERENCE STENCIL THAT IS C USED TO APPROXIMATE THE PDE. C C C B C C B A B U = RIGHT HAND SIDE C C B C C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT) C ON INPUT, U CONTAINS THE RIGHT HAND SIDE OF THE C DISCRETE APPROXIMATION TO THE PDE FOR EACH POINT C POINT AT WHICH THE SOLUTION IS TO BE DETERMINED, C I.E., (I,J), I=IL,..,IR, J=JL,..,JR. C ON OUTPUT THESE VALUES ARE REPLACED BY THE COMPUTED C SOLUTION. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C IL, IR, INTEGER SCALARS (INPUT) C JL, JR GIVES THE SUBSET OF GRID POINTS AT WHICH THE C SOLUTION IS TO BE DETERMINED, I.E., THAT SET C OF INDICES (I,J) WITH I=IL,..,IR AND J=JL,..,JR. C C WORK REAL ARRAY OF SIZE 5*N + 5*M + N/2 + 15 (WORKSPACE) C HERE N=IR-IL+1 AND M=JR-JL+1. THE LENGTH OF THIS C ARRAY MAY BE REDUCED BY M WHEN THE SOLUTION IS C NOT PERIODIC IN Y. IT MAY BE REDUCED BY 4*M IF C THE COEFFICIENT OF U IN THE PDE IS .LE. 0. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), LDXU, IL, IR, JL, JR REAL * A, B, C, U(LDXU,*), WORK(*) C C ... LOCAL VARIABLES C INTEGER N, M, LOCEWK, LOCFWK, LOCTWK, TOTAL C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C -------------- C INITIALIZATION C -------------- C N = IR - IL + 1 M = JR - JL + 1 LOC EWK = 1 LOC FWK = LOC EWK + N LOC TWK = LOC FWK + 3*N + N/2 + 15 TOTAL = LOC TWK + N + 5*M - 1 C CALL FFTI(BCTY(LEFT),BCTY(RIGHT),N,WORK(LOCFWK)) C C C ------------------ C FORWARD TRANSFORMS C ------------------ C CALL FFTF(BCTY(LEFT),BCTY(RIGHT),U,LDXU,IL,IR,JL,JR,WORK(LOCFWK)) C C C ------------------ C TRIDIAGONAL SOLVES C ------------------ C CALL TRISOL(A,B,C,BCTY,U,LDXU,IL,IR,JL,JR,WORK(LOCEWK), * WORK(LOCTWK)) C C C ------------------- C BACKWARD TRANSFORMS C ------------------- C CALL FFTB(BCTY(LEFT),BCTY(RIGHT),U,LDXU,IL,IR,JL,JR,WORK(LOCFWK)) C C C ---- C EXIT C ---- C RETURN END SUBROUTINE REFL2 (KDIST, NX, NY, PRDX, PRDY, G, LMXG) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C REFL2 EXTENDS A TWO-DIMENSIONAL GRID FUNCTION SO THAT IT IS C DEFINED ONE GRID LINE OUTSIDE ITS ORGINAL DOMAIN. THE EXTENTION C IS DONE BY REFLECTION THROUGH THE BOUNDARY EXCEPT WHERE C PERIODICITY IS SPECIFIED. C C C P A R A M E T E R S C ------------------- C C KDIST INTEGER SCALAR (INPUT) C INDICATES HOW THE GRID FUNCTION IS DEFINED. C POSSIBLE VALUES ARE C C 1 == FUNCTION DEFINED AT CENTER OF GRID SQUARES C 2 == FUNCTION DEFINED AT GRID POINTS C C NX INTEGER SCALAR (INPUT) C THE NUMBER OF GRID FUNCTION VALUES IN THE X DIRECTION. C C NY INTEGER SCALAR (INPUT) C THE NUMBER OF GRID FUNCTION VALUES IN THE Y DIRECTION. C C PRDX LOGICAL SCALAR (INPUT) C .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY C IN X. C C PRDY LOGICAL SCALAR (INPUT) C .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY C IN Y. C C G REAL ARRAY OF SIZE LMXG+1 BY NY+1 (INPUT/OUTPUT) C ON INPUT, THE GRID FUNCTION OCCUPIES G(I,J), I=1,..,NX, C J=1,..,NY. C ON OUTPUT, THE FUNCTION HAS BEEN EXTENDED TO INCLUDE THE C POINTS G(0,J), G(NX+1,J), G(I,0), G(I,NY+1), I=0,..,NX+1, C J=0,..,NY+1. C C LMXG INTEGER SCALAR (INPUT) C THE UPPER LIMIT OF THE FIRST DIMENSION OF THE ARRAY G. C MUST BE SET TO LDXU-1, WHERE LDXU IS THE ACTUAL LENGTH OF C THE FIRST DIMENSION OF G AS DECLARED IN THE CALLING C PROGRAM. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C LOGICAL PRDX, PRDY INTEGER KDIST, NX, NY, LMXG REAL * G(0:LMXG,0:*) C C C --------------- C INITIALIZATIONS C --------------- C NXP1 = NX + 1 NYP1 = NY + 1 C I0 = 1 + KDIST J0 = 1 + KDIST I1 = NX - KDIST J1 = NY - KDIST C C C ----------- C REFLECTIONS C ----------- C C ... IN Y DIRECTION C DO 10 I=1,NX G(I,0) = G(I,J0) G(I,NYP1) = G(I,J1) 10 CONTINUE C C ... IN X DIRECTION C DO 20 J=0,NYP1 G(0,J) = G(I0,J) G(NXP1,J) = G(I1,J) 20 CONTINUE C C C ------------------- C PERIODIC EXTENSIONS C ------------------- C C ... IN X DIRECTION C IF (PRDX) THEN DO 30 J=0,NYP1 G(0,J) = G(NXP1,J) 30 CONTINUE ENDIF C C ... IN Y DIRECTION C IF (PRDY) THEN DO 40 I=0,NXP1 G(I,0) = G(I,NYP1) 40 CONTINUE ENDIF C C C ---- C EXIT C ---- C RETURN END SUBROUTINE STORD2 (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C STORD2 STORES GIVEN DIRICHLET BOUNDARY DATA IN THE SOLUTION ARRAY U. C C C P A R A M E T E R S C ------------------- C C NX, NY INTEGER SCALARS (INPUT) C SEE HFFT2A. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C BD1, BD3 REAL ARRAYS OF SIZE NY (INPUT) C SEE HFFT2A. C C BD2, BD4 REAL ARRAYS OF SIZE NX (INPUT) C SEE HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY NY (OUTPUT) C ON OUTPUT, ENTRIES CORRESPONDING TO DIRICHLET BOUNDARY C POINTS CONTAIN THE KNOWN VALUES OF THE SOLUTION. C C LDXU INTEGER SCALAR (INPUT) C SEE HFFT2A. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER NX, NY, BCTY(4), LDXU REAL * BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY) C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C ---------------------- C HANDLE DIRICHLET SIDES C ---------------------- C C ... RIGHT SIDE C IF (BCTY(RIGHT) .EQ. DRCH) THEN DO 210 J = 1,NY U(NX,J) = BD1(J) 210 CONTINUE ENDIF C C ... BOTTOM SIDE C IF (BCTY(BOTTOM) .EQ. DRCH) THEN DO 220 I=1,NX U(I,1) = BD2(I) 220 CONTINUE ENDIF C C ... LEFT SIDE C IF (BCTY(LEFT) .EQ. DRCH) THEN DO 230 J=1,NY U(1,J) = BD3(J) 230 CONTINUE ENDIF C C ... TOP SIDE C IF (BCTY(TOP) .EQ. DRCH) THEN DO 240 I=1,NX U(I,NY) = BD4(I) 240 CONTINUE ENDIF C C ------------------------ C HANDLE DIRICHLET CORNERS C ------------------------ C IF ((BCTY(TOP) .EQ. DRCH) .AND. (BCTY(RIGHT) .EQ. DRCH)) * U(NX,NY) = 0.50E0*( BD4(NX) + BD1(NY) ) IF ((BCTY(RIGHT) .EQ. DRCH) .AND. (BCTY(BOTTOM) .EQ. DRCH)) * U(NX,1) = 0.50E0*( BD1(1) + BD2(NX) ) IF ((BCTY(BOTTOM) .EQ. DRCH) .AND. (BCTY(LEFT) .EQ. DRCH)) * U(1,1) = 0.50E0*( BD2(1) + BD3(1) ) IF ((BCTY(LEFT) .EQ. DRCH) .AND. (BCTY(TOP) .EQ. DRCH)) * U(1,NY) = 0.50E0*( BD3(NY) + BD4(1) ) C C ---- C EXIT C ---- C RETURN END SUBROUTINE TRISOL (A, B, C, BCTY, U, LDXU, IL, IR, JL, JR, * EIGEN, WORK) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C JOAN M. BAUMANN C NATIONAL BUREAU OF STANDARDS C C DECEMBER 1985 (REVISED APRIL 1987) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C TRISOL SOLVES THE SET OF TRIDIAGONAL LINEAR SYSTEMS OF EQUATIONS C OBTAINED FROM THE MATRIX DECOMPOSITION ALGORITHM (FOURIER METHOD). C C N TRIDIAGONAL SYSTEMS OF ORDER M ARE SOLVED, WHERE N=IR-IL+1 C AND M=JR-JL+1. EACH SYSTEM IS SYMMETRIC WITH CONSTANT DIAGONALS C (THE TOP LEFT AND BOTTOM RIGHT ELEMENTS MAY BE MULTIPLIED BY 1/2, C DEPENDING UPON THE BOUNDARY CONDITIONS). THE MATRIX COEFFICIENTS C DEPEND UPON THE FINITE DIFFERENCE STENCIL COEFFICIENTS A, B, C, AND C THE BOUNDARY CONDITIONS GIVEN BY BCTY. THE RIGHT HAND SIDES OF THE C SYSTEMS ARE STORED IN THE ROWS OF U. C C C P A R A M E T E R S C ------------------- C C A, B, C REAL SCALARS (INPUT) C SEE MDALG2. C C BCTY INTEGER ARRAY OF SIZE 4 (INPUT) C SEE HFFT2A. C C U REAL ARRAY OF SIZE LDXU BY M (INPUT/OUTPUT) C ON INPUT THE RIGHT HAND SIDES OF THE LINEAR SYSTEMS C TO BE SOLVED ARE STORED IN THE ROWS OF U, I.E., THE C ITH RIGHT HAND SIDE IS IN U(I,J), J=JL,..,JR, FOR C I=IL,..,IR. ON OUTPUT THESE ARE REPLACED BY THE C SOLUTIONS OF THE LINEAR SYSTEMS. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C IL, IR, INTEGER SCALARS (INPUT) C JL, JR SPECIFY THE SUBARRAY OF U IN WHICH THE RIGHT HAND C SIDES OF THE SYSTEMS ARE STORED. SEE U ABOVE. C C EIGEN REAL ARRAY OF SIZE N (WORKSPACE) C C WORK REAL ARRAY OF SIZE 5*M + N. THIS LENGTH MAY BE REDUCED C BY 4*M IF THE COEFFICIENT OF U IN THE PDE IS .LE. 0. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER BCTY(4), LDXU, IL, IR, JL, JR REAL * A, B, C, U(LDXU,*), EIGEN(*), WORK(*) C C ... LOCAL VARIABLES C INTEGER N, M REAL * MU, NU C C ... LOCAL CONSTANTS C INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM PARAMETER (DRCH=1, NEUM =2, PRDC=3, * LEFT=3, RIGHT=1, TOP =4, BOTTOM=2) C C C --------------- C INITIALIZATIONS C --------------- C N = IR - IL + 1 M = JR - JL + 1 C MU = 1.0E0 NU = 1.0E0 IF (BCTY(BOTTOM) .EQ. NEUM) MU = 0.5E0 IF (BCTY(TOP ) .EQ. NEUM) NU = 0.5E0 CALL EVDISC(BCTY(LEFT),BCTY(RIGHT),EIGEN,N) C C C ------------------------- C SOLVE TRIDIAGONAL SYSTEMS C ------------------------- C C ... CALCULATE THE CONSTANT DIAGONALS AND OFF-DIAGONALS OF THE C SYSTEMS TO BE SOLVED, STORING THEM IN THE ARRAYS EIGEN C AND WORK, RESPECTIVELY C DO 100 K=1,N WORK(K) = B + C*EIGEN(K) EIGEN(K) = A + B*EIGEN(K) 100 CONTINUE C C ... SOLVE SYSTEMS C CALL TRSALL (EIGEN, WORK, U, LDXU, MU, NU, IL, IR, JL, JR, * BCTY(BOTTOM).EQ.PRDC, WORK(N+1) ) C C C ---- C EXIT C ---- C RETURN END SUBROUTINE TRSALL (DIAG, OFFDG, U, LDXU, MU, NU, IL, IR, JL, JR, * PRDC, WORK ) C C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C JOAN M. BAUMANN C NATIONAL BUREAU OF STANDARDS C C DECEMBER 1985 (REVISED APRIL 1987) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C TRSALL SOLVES N TRIDIAGONAL SYSTEMS OF LINEAR EQUATIONS OF SIZE C M, WHERE N=IR=IL+1 AND M=JR-JL+1. ALL OF THE SYSTEMS AU=G MUST C HAVE MATRICES A OF ONE OF THE FOLLOWING FORMS. C C :-- --: C : MU*A B : C : B A B : C : B A B : C A = : . . . : C : . . . : C : B A B : C : B A*NU : C :-- --: C C AND MU AND NU HAVING THE VALUES 0.5 OR 1.0, OR C C :-- --: C : A B B : C : B A B : C : B A B : C A = : . . . : C : . . . : C : B A B : C : B B A : C :-- --: C C C ALL SYSTEMS MUST BE OF THE SAME FORM, ALTHOUGH THE SCALARS A AND B C MAY BE DIFFERENT FOR EACH SYSTEM. C C ONE OF TWO ALGORITHMS IS USED DEPENDING UPON THE VALUES OF A AND B. C IF ABS(A) .GE. ABS(2*B) THEN AN EXTENSION OF AN ALGORITHM DUE TO EVA C IS USED; OTHERWISE GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING FOR C GENERAL TRIDIAGONAL MATRICES IS USED. C C C P A R A M E T E R S C ------------------- C C DIAG REAL ARRAY OF SIZE N (INPUT) C CONSTANT DIAGONALS FOR THE SYSTEMS TO BE SOLVED. C THE DIAGONAL ELEMENT A FOR THE I-TH SYSTEM IS STORED C IN DIAG(K). C C OFFDG REAL ARRAY OF SIZE N (INPUT) C CONSTANT OFF-DIAGONALS FOR THE SYSTEMS TO BE SOLVED. C THE OFF-DIAGONAL ELEMENT A FOR THE I-TH SYSTEM IS C STORED IN OFFDG(I). C C U REAL ARRAY OF SIZE LDXU BY M (INPUT/OUTPUT) C ON INPUT THE RIGHT HAND SIDES OF THE LINEAR SYSTEMS C TO BE SOLVED ARE STORED IN THE ROWS OF U, I.E., THE C ITH RIGHT HAND SIDE IS IN U(I,J), J=JL,..,JR, FOR C I=IL,..,IR. C ON OUTPUT THESE ROWS ARE REPLACED BY THE SOLUTIONS C OF THE LINEAR SYSTEMS. C C LDXU INTEGER SCALAR (INPUT) C THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS C SPECIFIED IN THE CALLING PROGRAM. C C MU,NU REAL SCALARS (INPUT) C MULTIPLICATIVE FACTORS FOR THE FIRST AND LAST C DIAGONAL ELEMENTS, RESPECTIVELY, FOR EACH OF THE C LINEAR SYSTEMS. THESE ARE IGNORED IF PRDC=.TRUE. C C IL, IR, INTEGER SCALARS (INPUT) C JL, JR SPECIFY THE SUBARRAY OF U IN WHICH THE RIGHT HAND C SIDES OF THE SYSTEMS ARE STORED. SEE U ABOVE. C C PRDC LOGICAL VARIABLE (INPUT) C INDICATES THE FORM OF THE MATRICES. IS .TRUE. FOR C THE PERIODIC CASE (SECOND CASE ABOVE), AND .FALSE. C OTHERWISE. C C WORK REAL WORK ARRAY OF SIZE 5*M. THIS CAN BE REDUCED TO C M IF ABS(DIAG(K)) .GE. 2*ABS(OFFDG(K)) FOR ALL K. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER LDXU, IL, IR, JL, JR REAL DIAG(*), OFFDG(*), U(LDXU,*), WORK(*), MU, NU LOGICAL PRDC C C ... LOCAL VARIABLES C INTEGER K, KX, IPOS, INFO REAL CORNER C C ... LOCAL CONSTANTS C INTEGER M, LOCC, LOCD, LOCE, LOCW C M = JR - JL + 1 LOCC = 1 + M LOCD = LOCC + M LOCE = LOCD + M LOCW = LOCE + M C C C ------------------------- C SOLVE TRIDIAGONAL SYSTEMS C ------------------------- C K = 0 DO 500 I=IL,IR K = K + 1 C C ... CONSTRUCT RIGHT HAND SIDE C KX = 0 DO 100 J=JL,JR KX = KX + 1 WORK(KX) = U(I,J) 100 CONTINUE WORK(1) = WORK(1)*MU WORK(M) = WORK(M)*NU C C ... SOLVE C IF (ABS(DIAG(K)) .GE. 2.0*ABS(OFFDG(K))) THEN C C ... CASE OF COEFU .LE. 0 -- USE EVANS ALGORITHM C IF (PRDC) THEN CALL TRSOLP(DIAG(K), OFFDG(K), WORK, M, INFO) ELSE CALL TRSOLG (DIAG(K), OFFDG(K), MU, NU, WORK, M, INFO) ENDIF ELSE C C ... CASE OF COEFU .GT. 0 -- USE GAUSS WITH PIVOTING C DO 200 IPOS=0,M-1 WORK(LOCC+IPOS) = OFFDG(K) WORK(LOCE+IPOS) = OFFDG(K) WORK(LOCD+IPOS) = DIAG(K) 200 CONTINUE WORK(LOCD) = MU*WORK(LOCD) WORK(LOCD+M-1) = NU*WORK(LOCD+M-1) CORNER = 0.0E0 IF (PRDC) CORNER = OFFDG(K) CALL SGPSL(M, WORK(LOCC), WORK(LOCD), WORK(LOCE),CORNER, + CORNER, WORK, WORK(LOCW), INFO) ENDIF C C ... REPLACE ROW C KX = 0 DO 300 J=JL,JR KX = KX + 1 U(I,J) = WORK(KX) 300 CONTINUE 500 CONTINUE C C C ---- C EXIT C ---- C RETURN END SUBROUTINE TRSOLG (A, B, MU, NU, G, NG, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C JOAN M. BAUMANN C NATIONAL BUREAU OF STANDARDS C DECEMBER 1985 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C TRSOLG SOLVES THE TRIDIAGONAL SYSTEM AX = G, WHERE C C :-- --: C : MU*A B : C : B A B : C : B A B : C A = : . . . : C : . . . : C : B A B : C : B A*NU : C :-- --: C C WHERE ABS(A).GE.2*ABS(B)) AND MU AND NU HAVE ONE OF THE VALUES C 0.5 OR 1.0. C C C ALGORITHM C C THE ALGORITHM USED IS N EXTENSION OF AN INTERLOCKING FACTORIZATION C METHOD DUE TO EVANS. C C REFERENCE: D. J. EVANS, AN ALGORITHM FOR THE SOLUTION OF CERTAIN C TRIDIAGONAL SYSTEMS OF LINEAR EQUATIONS, THE COMPUTER JOURNAL, C VOL. 15, PP. 356-359. C C C DEGENERATE CASES C C WHEN MU=NU=0.5 AND ABS(A).EQ.2*ABS(B) THE MATRIX A IS SINGULAR. C IN THESE CASES A CERTAIN CONSISTENCY CONDITION MUST BE SATISFIED; C IF IT IS, THERE ARE AN INFINITE NUMBER OF SOLUTIONS, EACH DIFFERING C BY AN ADDITIVE CONSTANT. THE CONSISTENCY CONDITIONS ARE C C CASE -A=2B : SUM(I=1,..,NG) G(I) = 0 C CASE A=2B : SUM(I ODD) G(I) + SUM(I EVEN) G(I) = 0 C C WE ASSUME THESE CONDITIONS HOLD AND SELECT THE UNIQUE SOLUTION WITH C G(NG) = 0.0. C C C P A R A M E T E R S C ------------------- C C A REAL SCALAR (INPUT) C CONSTANT DIAGONAL FOR THE SYSTEM TO BE SOLVED. C C B REAL SCALAR (INPUT) ABS(A) .GE. 2*ABS(B) C CONSTANT OFF-DIAGONAL FOR THE SYSTEM TO BE SOLVED. C C MU,NU REAL SCALARS (INPUT) .EQ. 0.5 OR 1.0 C MULTIPLICATIVE FACTORS FOR FIRST AND LAST DIAGONAL C ELEMENTS, RESPECTIVELY. C C G REAL ARRAY OF SIZE M (INPUT/OUTPUT) C ON INPUT, CONTAINS THE RIGHT HAND SIDE OF THE LINEAR C SYSTEM. ON OUTPUT THIS IS REPLACED BY THE SOLUTIONONS C VECTOR. C C NG INTEGER SCALAR (INPUT) .GE. 2 C THE NUMBER OF ROWS IN THE SYSTEMS TO BE SOLVED. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 0 == SUBROUTINE RAN TO COMPLETION (SUCCESS) C 1 == ERROR. ABS(A).LT.2*ABS(B) C 2 == ERROR. N.LT.2 C 3 == ERROR. MU OR NU .NE. 0.5 OR 1.0 C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C REAL A, B, MU, NU, G(NG) INTEGER NG, INFO C C ... LOCAL VARIABLES C REAL AA INTEGER KASE, N C C ... LOCAL CONSTANTS C REAL ALPHA, ALPHA2, BETA, BETA2, GAMMA2, DELTA, * EPS, XN, CON1, CON2, ZERO, ONE, TWO, FOUR, HALF, EPMACH C SAVE ZERO, ONE, TWO, FOUR, HALF DATA ZERO, ONE, TWO, FOUR, HALF * / 0.0E0, 1.0E0, 2.0E0, 4.0E0, 0.50E0 / C C C --------------- C INITIALIZATIONS C --------------- C N = NG EPMACH = R1MACH(4) EPS = 50.0E0*EPMACH IF (ABS(MU - HALF) .LT. EPS) MU = HALF IF (ABS(MU - ONE ) .LT. EPS) MU = ONE IF (ABS(NU - HALF) .LT. EPS) NU = HALF IF (ABS(NU - ONE ) .LT. EPS) NU = ONE C C ... CHECK FOR ILLEGAL INPUT PARAMETERS C INFO = 0 IF (((MU .NE. HALF) .AND. (MU .NE. ONE)) .OR. * ((NU .NE. HALF) .AND. (NU .NE. ONE)) ) INFO = 3 IF (N .LT. 2) INFO = 2 IF ((ABS(A) - TWO*ABS(B)) .LT. ZERO) INFO = 1 IF (INFO .NE. 0) GO TO 999 C C C ----------------------- C CHECK FOR B=0, CASE = 6 C ----------------------- C IF (ABS(B/A) .LT. EPMACH) GO TO 600 C C C --------------------------- C PREPROCESSING FOR CASES 1-5 C --------------------------- C ALPHA = -TWO*B/(A + SQRT(MAX(ZERO,A*A - FOUR*B*B))) IF (ABS(ALPHA) .GT. ONE) ALPHA = ONE/ALPHA ALPHA2 = ALPHA*ALPHA BETA2 = MU*(ONE + ALPHA2) - ALPHA2 BETA = SQRT(BETA2) GAMMA2 = NU*(ONE + ALPHA2) - ONE C C ... RESCALE SYSTEM TO TRIDIAGONAL(-ALPHA,1+ALPHA**2,-ALPHA) C CON1 = (ONE + ALPHA2)/A DO 10 I=1,N G(I) = CON1*G(I) 10 CONTINUE C C C -------------- C DETERMINE CASE C -------------- C C KASE = 1 == ABS(ALPHA) < 1.0 C KASE = 2 == ABS(ALPHA) = 1.0, MU = 1.0, NU = 1.0 C KASE = 3 == ABS(ALPHA) = 1.0, MU = .5, NU = .5 C KASE = 4 == ABS(ALPHA) = 1.0, MU = .5, NU = 1.0 C KASE = 5 == ABS(ALPHA) = 1.0, MU = 1.0, NU = .5 C IF ((-ONE + EPS .LE. ALPHA) .AND. (ALPHA .LE. ONE - EPS)) THEN KASE = 1 ELSE IF ((MU .EQ. ONE) .AND. (NU .EQ. ONE)) THEN KASE = 2 ELSE IF ((MU .EQ. HALF) .AND. (NU .EQ. HALF)) THEN KASE = 3 ELSE IF ((MU .EQ. HALF) .AND. (NU .EQ. ONE)) THEN KASE = 4 ELSE IF ((MU .EQ. ONE) .AND. (NU .EQ. HALF)) THEN KASE = 5 ELSE INFO = 3 GO TO 999 ENDIF GO TO (100, 200, 300, 400, 500), KASE C C C ------ C CASE 1 C ------ C C ... PREPROCESSING C 100 CONTINUE CON2 = (ONE - ALPHA2 - BETA2)/BETA2 AA = ALPHA XN = G(N) DO 110 J=1,N-2 XN = XN + AA*G(N-J) AA = AA*ALPHA 110 CONTINUE XN = XN + AA*(ONE - ALPHA2)/BETA2*G(1) DO 120 J=2,N AA = AA*ALPHA XN = XN + CON2*AA*G(J) 120 CONTINUE DELTA = ONE - ALPHA2 + GAMMA2 + GAMMA2*CON2*AA XN = XN/DELTA GOTO 220 C C C ------ C CASE 2 C ------ C C ... PREPROCESSING C 200 CONTINUE XN = ZERO IF (MOD(N-1,2) .EQ. 1) THEN AA = ALPHA ELSE AA = ONE ENDIF DO 210 K=1,N-1 XN = XN + G(K)*REAL(K)*AA AA = AA*ALPHA 210 CONTINUE XN = (XN + G(N)*REAL(N))/REAL(N+1) C C ... BACK SUBSTITUTION (CASES 1 AND 2) C 220 CONTINUE G(N) = G(N) - GAMMA2*XN DO 230 I=N-1,2,-1 G(I) = G(I) + ALPHA*G(I+1) 230 CONTINUE G(1) = (G(1) + ALPHA*G(2))/BETA C C ... FORWARD ELIMINATION (CASES 1 AND 2) C G(1) = G(1)/BETA DO 240 I=2,N-1 G(I) = G(I) + ALPHA*G(I-1) 240 CONTINUE G(N)=XN GO TO 999 C C C -------------------------- C CASE 3 : CONVERT TO CASE 4 C -------------------------- C 300 CONTINUE G(N) = ZERO N = N-1 C C ------ C CASE 4 C ------ C C ... FORWARD ELIMINATION C 400 CONTINUE G(1) = -ALPHA*G(1) DO 410 I=2,N G(I) = -ALPHA*(G(I) - G(I-1)) 410 CONTINUE C C ... BACK SUBSTITUTION C G(N) = -ALPHA*G(N) DO 420 I=N-1,1,-1 G(I) = -ALPHA*(G(I) - G(I+1)) 420 CONTINUE GO TO 999 C C C ------ C CASE 5 C ------ C C ... BACK SUBSTITUTION C 500 CONTINUE DO 510 I=N-1,1,-1 G(I) = G(I) + ALPHA*G(I+1) 510 CONTINUE C C ... FORWARD ELMINATION C DO 520 I=2,N G(I) = G(I) + ALPHA*G(I-1) 520 CONTINUE GO TO 999 C C C ------------------------ C CASE 6 : DIAGONAL SYSTEM C ------------------------ C 600 CONTINUE DO 610 I=1,N G(I) = G(I)/A 610 CONTINUE G(1) = G(1)/MU G(N) = G(N)/NU GO TO 999 C C C ---- C EXIT C ---- C 999 CONTINUE RETURN END SUBROUTINE TRSOLP (A, B, G, NG, INFO) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C JOAN M. BAUMANN C NATIONAL BUREAU OF STANDARDS C C DECEMBER 1985 (REVISED APRIL 1987) C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C C TRSOLP SOLVES THE TRIDIAGONAL LINEAR SYSTEM AX = G, WHERE C C :-- --: C : A B B : C : B A B : C : B A B : C A = : . . . : C : . . . : C : B A B : C : B B A : C :-- --: C C WHERE ABS(A).GE.ABS(2*B). C C C ALGORITHM C C THE ALGORITHM USED IS AN INTERLOCKING FACTORIZATION METHOD DUE TO C EVANS. C C REFERENCE: D. J. EVANS, FAST ADI METHODS FOR THE SOLUTION OF LINEAR C PARABOLIC PARTIAL DIFFERENTIAL EQUATIONS INVOLVING 2 SPACE C DIMENSIONS, BIT, VOL. 17, P.486-491. C C C DEGENERATE CASES C C WHEN -A=2B OR WHEN A=2B AND NG IS EVEN THE MATRIX A IS SINGULAR. C IN THESE CASES THERE ARE NO SOLUTIONS UNLESS G SATISFIES A CERTAIN C CONSISTENCY CONDITION. WHEN IT DOES, THERE ARE AN INFINITE NUMBER C OF SOLUTIONS, EACH DIFFERENING BY AN ADDITVE CONSTANT. THE C CONSISTENCY CONDITIONS ARE C C CASE -A=2B : SUM(I=1,..,NG) G(I) = 0 C CASE A=2B, NG EVEN : SUM(I ODD) G(I) - SUM(I EVEN) G(I) = 0 C C WE ASSUME THESE CONDITIONS HOLD AND SELECT THE UNIQUE SOLUTION WITH C G(NG) = 0.0. C C C ------------------- C P A R A M E T E R S C ------------------- C C A REAL SCALAR (INPUT) C CONSTANT DIAGONAL FOR THE SYSTEM TO BE SOLVED C C B REAL SCALAR (INPUT) C CONSTANT OFF-DIAGONAL FOR THE SYSTEM TO BE SOLVED C C G REAL ARRAY OF SIZE M (INPUT/OUTPUT) C ON INPUT THE RIGHT HAND SIDES OF THE LINEAR C SYSTEMS TO BE SOLVED ARE STORED IN THE ROWS C OF G, I.E., THE ITH RIGHT HAND SIDE IS IN G(I). C ON OUTPUT THESE ARE REPLACED BY THE SOLUTIONS C OF THE LINEAR SYSTEMS. C C NG INTEGER SCALAR (INPUT) C THE NUMBER OF ROWS IN THE SYSTEMS TO BE SOLVED. C C INFO INTEGER SCALAR (OUTPUT) C INDICATES STATUS OF COMPUTED SOLUTION. C POSSIBLE VALUES ARE C C 0 == SUBROUTINE RAN TO COMPLETION (SUCCESS) C 1 == ERROR. ABS(A).LT.2*ABS(B) C 2 == ERROR. N.LT.3 C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C REAL A, B, G(NG) INTEGER NG, INFO C C ... LOCAL VARIABLES C REAL AA INTEGER N C C ... LOCAL CONSTANTS C REAL ALPHA, EPS, FACTOR, ZERO, ONE, TWO, FOUR, EPMACH C SAVE ZERO, ONE, TWO, FOUR DATA ZERO, ONE, TWO, FOUR * / 0.0E0, 1.0E0, 2.0E0, 4.0E0 / C C C --------------- C INITIALIZATIONS C --------------- C N = NG EPMACH = R1MACH(4) EPS = 50.0E0*EPMACH C C ... CHECK FOR ILLEGAL INPUT PARAMETERS C INFO = 0 C IF ((ABS(A) - 2.0E0*ABS(B)) .LT. ZERO) INFO = 1 IF (N .LT. 3) INFO = 2 IF (INFO .NE. 0) GO TO 999 C C C ------------------ C CHECK FOR B=0 CASE C ------------------ C IF (ABS(B/A) .LT. EPMACH) GO TO 200 C C C -------------------------------------------------------- C RESCALE PROBLEM TO TRIDIAGONAL(-ALPHA,1+ALPHA**2,-ALPHA) C -------------------------------------------------------- C ALPHA = -TWO*B/(A + SQRT(MAX(ZERO,A*A - FOUR*B*B))) IF (ABS(ALPHA) .GT. ONE) ALPHA = ONE/ALPHA FACTOR = (ONE + ALPHA*ALPHA)/A DO 10 I = 1,N G(I) = FACTOR*G(I) 10 CONTINUE C C C ----------------------- C CHECK FOR SINGULAR CASE C ----------------------- C IF (((ABS(ONE + ALPHA) .LE. EPS) .AND. (MOD(N,2) .EQ. 0)) .OR. * (ABS(ONE - ALPHA) .LE. EPS)) GO TO 300 C C C ------------- C STANDARD CASE C ------------- C C ... PREPROCESSING C AA = ALPHA DO 20 I = N,2,-1 G(1) = G(1) + AA*G(I) AA = AA*ALPHA 20 CONTINUE G(1) = G(1)/(ONE - AA) C C ... FORWARD ELIMINATION C DO 40 I = 2,N G(I) = G(I) + ALPHA*G(I-1) 40 CONTINUE C C ... DETERMINE INTERLOCKING ELEMENT XN C AA = ALPHA DO 45 I = 1,N-1 G(N) = G(N) + AA*G(I) AA = AA*ALPHA 45 CONTINUE G(N) = G(N)/(ONE - AA) C C ... BACK SUBSTITUTION C DO 50 I = N-1,1,-1 G(I) = G(I) + ALPHA*G(I+1) 50 CONTINUE GO TO 999 C C C --------------------- C SPECIAL CASE : B = 0 C --------------------- C 200 CONTINUE DO 210 I=1,N G(I) = G(I)/A 210 CONTINUE GO TO 999 C C C -------------------------------- C SPECIAL CASE : SINGULAR PROBLEM C -------------------------------- C 300 CONTINUE G(N) = ZERO CALL TRSOLG (ONE + ALPHA*ALPHA, -ALPHA, ONE, ONE, G, N-1, INFO) GO TO 999 C C C ---- C EXIT C ---- C 999 CONTINUE RETURN END SUBROUTINE SGPSL (N,C,D,E,C0,E0,B,W,INFO) C C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* C C --------------- 4TH ORDER ACCURATE FAST DIRECT SOLUTION C PACKAGE : HFFT OF THE HELMHOLTZ EQUATION ON RECTANGULAR C --------------- DOMAINS IN TWO AND THREE DIMENSIONS C C INTERNAL MODULE C C RONALD F. BOISVERT C NATIONAL BUREAU OF STANDARDS C C APRIL 1987 C C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* * C C SGPSL SOLVES A LINEAR SYSTEM OF EQUATIONS DEFINED BY A GENERAL C TRIDIAGONAL MATRIX WITH ADDITIONAL NONZEROS IN THE (1,N) AND (N,1) C POSITIONS USING GAUSS ELIMINATION WITH PARTIAL PIVOTING. C C C P A R A M E T E R S C ------------------- C C ON ENTRY C C N INTEGER (N.GE.3) C IS THE ORDER OF THE TRIDIAGONAL MATRIX. C C C REAL(N) C IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX. C C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL. C ON OUTPUT, C IS DESTROYED. C C D REAL(N) C IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX. C ON OUTPUT, D IS DESTROYED. C C E REAL(N) C IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX. C E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL. C ON OUTPUT, E IS DESTROYED. C C C0 REAL C THE NONZERO ELEMENT A(1,N). C C E0 REAL C THE NONZERO ELEMENT A(N,1). C C B REAL(N) C IS THE RIGHT HAND SIDE VECTOR. C C W REAL(N) C WORKSPACE. C C ON RETURN C C B IS THE SOLUTION VECTOR. C C INFO INTEGER C = -1 IF N .LT. 3 C = 0 NORMAL VALUE. C = K IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES C EXACTLY ZERO. THE SUBROUTINE RETURNS WHEN C THIS IS DETECTED. C C THIS IS A MODIFICATION OF THE LINPACK ROUTINE SGTSL. C C C ------------ C DECLARATIONS C ------------ C C ... PARAMETERS C INTEGER N, INFO REAL C(N), D(N), E(N), B(N), W(N) C C ... LOCAL VARIABLES C LOGICAL LASROW INTEGER K, KBIG, KP1, KP2, NM1, NM2, NM3 REAL T, RK, RKP1, RKP2, A(3,3) C C C --------------- C INITIALIZATIONS C --------------- C INFO = -1 IF (N .LE. 3) GO TO 100 C NM1 = N - 1 NM2 = N - 2 NM3 = N - 3 C ZERO = 0.0E0 LASROW = E0 .NE. ZERO RKP1 = E0 RKP2 = ZERO W(1) = C0 DO 10 I=2,NM2 W(I) = ZERO 10 CONTINUE W(NM1) = E(NM1) W(N) = D(N) C C(1) = D(1) D(1) = E(1) E(1) = ZERO E(N) = ZERO C C ------------------- C FORWARD ELIMINATION C ------------------- C DO 30 K = 1, NM3 INFO = K KP1 = K + 1 KP2 = K + 2 RK = RKP1 RKP1 = RKP2 RKP2 = ZERO IF (K .EQ. NM3) RKP2 = C(N) C C ... FIND THE LARGEST OF THE TWO ROWS C IF (ABS(C(KP1)) .GT. ABS(C(K))) THEN C C ... INTERCHANGE ROW C T = C(KP1) C(KP1) = C(K) C(K) = T T = D(KP1) D(KP1) = D(K) D(K) = T T = E(KP1) E(KP1) = E(K) E(K) = T T = W(KP1) W(KP1) = W(K) W(K) = T T = B(KP1) B(KP1) = B(K) B(K) = T ENDIF C C ... CHECK FOR SINGULARITY C IF (C(K) .EQ. ZERO) GO TO 100 C C ... ELIMINATE IN ROW K+1 C T = -C(KP1)/C(K) C(KP1) = D(KP1) + T*D(K) D(KP1) = E(KP1) + T*E(K) E(KP1) = ZERO W(KP1) = W(KP1) + T*W(K) B(KP1) = B(KP1) + T*B(K) C C ... ELIMINATE IN LAST ROW C IF (LASROW) THEN T = -RK/C(K) RKP1 = RKP1 + T*D(K) RKP2 = RKP2 + T*E(K) W(N) = W(N) + T*W(K) B(N) = B(N) + T*B(K) ENDIF 30 CONTINUE C C ... DO LAST 3 BY 3 BLOCK C A(1,1) = C(NM2) A(1,2) = D(NM2) A(1,3) = W(NM2) A(2,1) = C(NM1) A(2,2) = D(NM1) A(2,3) = W(NM1) A(3,1) = RKP1 A(3,2) = RKP2 A(3,3) = W(N) C C === STEP N-2 === C INFO = NM2 KBIG = 1 IF (ABS(A(2,1)) .GT. ABS(A(1,1))) KBIG = 2 IF (ABS(A(3,1)) .GT. ABS(A(KBIG,1))) KBIG = 3 IF (KBIG .NE. 1) THEN C C ... PIVOT C T = A(KBIG,1) A(KBIG,1) = A(1,1) A(1,1) = T T = A(KBIG,2) A(KBIG,2) = A(1,2) A(1,2) = T T = A(KBIG,3) A(KBIG,3) = A(1,3) A(1,3) = T K = NM3 + KBIG T = B(K) B(K) = B(NM2) B(NM2) = T ENDIF IF (A(1,1) .EQ. ZERO) GO TO 100 C C ... ELIMINATE C T = -A(2,1)/A(1,1) A(2,2) = A(2,2) + T*A(1,2) A(2,3) = A(2,3) + T*A(1,3) B(NM1) = B(NM1) + T*B(NM2) T = -A(3,1)/A(1,1) A(3,2) = A(3,2) + T*A(1,2) A(3,3) = A(3,3) + T*A(1,3) B(N) = B(N) + T*B(NM2) C C === STEP N-1 === C INFO = NM1 IF (ABS(A(3,2)) .GT. ABS(A(2,2))) THEN C C ... PIVOT C T = A(3,2) A(3,2) = A(2,2) A(2,2) = T T = A(3,3) A(3,3) = A(2,3) A(2,3) = T T = B(N) B(N) = B(NM1) B(NM1) = T ENDIF IF (A(2,2) .EQ. ZERO) GO TO 100 C C ... ELIMINATE C T = -A(3,2)/A(2,2) A(3,3) = A(3,3) + T*A(2,3) B(N) = B(N) + T*B(NM1) C C === STEP N === C INFO = N IF (A(3,3) .EQ. ZERO) GO TO 100 C C ---------- C BACK SOLVE C ---------- C B(N) = B(N)/A(3,3) B(NM1) = (B(NM1) - A(2,3)*B(N))/A(2,2) B(NM2) = (B(NM2) - A(1,2)*B(NM1) - A(1,3)*B(N))/A(1,1) DO 60 K = NM3, 1, -1 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2) - W(K)*B(N))/C(K) 60 CONTINUE INFO = 0 C C ---- C EXIT C ---- C 100 CONTINUE RETURN END * SUBROUTINE COSQB(N,X,WSAVE) C***BEGIN PROLOGUE COSQB C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE UNNORMALIZED INVERSE OF COSQF. C***DESCRIPTION C C SUBROUTINE COSQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS, COSQB COMPUTES A SEQUENCE FROM ITS C REPRESENTATION IN TERMS OF A COSINE SERIES WITH ODD WAVE NUMBERS. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. C C COSQB IS THE UNNORMALIZED INVERSE OF COSQF SINCE A CALL OF COSQB C FOLLOWED BY A CALL OF COSQF WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQB MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY THAT MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS COSQB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I)= THE SUM FROM K=1 TO K=N OF C C 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) C C A CALL OF COSQB FOLLOWED BY A CALL OF C COSQF WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE COSQF IS THE UNNORMALIZED INVERSE C OF COSQB. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF COSQB OR COSQF. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED COSQB1 C***END PROLOGUE COSQB DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT COSQB TSQRT2 = 2.*SQRT(2.) IF (N-2) 101,102,103 101 X(1) = 4.*X(1) RETURN 102 X1 = 4.*(X(1)+X(2)) X(2) = TSQRT2*(X(1)-X(2)) X(1) = X1 RETURN 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1)) RETURN END SUBROUTINE COSQF(N,X,WSAVE) C***BEGIN PROLOGUE COSQF C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS. C***DESCRIPTION C C SUBROUTINE COSQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS, COSQF COMPUTES THE COEFFICIENTS IN A COSINE C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM C IS DEFINED BELOW AT OUTPUT PARAMETER X C C COSQF IS THE UNNORMALIZED INVERSE OF COSQB SINCE A CALL OF COSQF C FOLLOWED BY A CALL OF COSQB WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQF MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS COSQF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I) = X(1) PLUS THE SUM FROM K=2 TO K=N OF C C 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) C C A CALL OF COSQF FOLLOWED BY A CALL OF C COSQB WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE COSQB IS THE UNNORMALIZED INVERSE C OF COSQF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF COSQF OR COSQB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED COSQF1 C***END PROLOGUE COSQF DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT COSQF SQRT2 = SQRT(2.) IF (N-2) 102,101,103 101 TSQX = SQRT2*X(2) X(2) = X(1)-TSQX X(1) = X(1)+TSQX 102 RETURN 103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1)) RETURN END SUBROUTINE COSQI(N,WSAVE) C***BEGIN PROLOGUE COSQI C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE INITIALIZE FOR COSQF AND COSQB. C***DESCRIPTION C C SUBROUTINE COSQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH COSQF AND COSQB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE ARRAY TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C THE SAME WORK ARRAY CAN BE USED FOR BOTH COSQF AND COSQB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF COSQF OR COSQB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTI C***END PROLOGUE COSQI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT COSQI PIH = 2.*ATAN(1.) DT = PIH/REAL(N) FK = 0. DO 101 K=1,N FK = FK+1. WSAVE(K) = COS(FK*DT) 101 CONTINUE CALL RFFTI (N,WSAVE(N+1)) RETURN END SUBROUTINE COSTI(N,WSAVE) C***BEGIN PROLOGUE COSTI C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE INITIALIZE FOR COST. C***DESCRIPTION C C SUBROUTINE COSTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C SUBROUTINE COST. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF SMALL PRIMES. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES C OF N. THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN C CALLS OF COST. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTI C***END PROLOGUE COSTI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT COSTI PI = 4.*ATAN(1.) IF (N .LE. 3) RETURN NM1 = N-1 NP1 = N+1 NS2 = N/2 DT = PI/REAL(NM1) FK = 0. DO 101 K=2,NS2 KC = NP1-K FK = FK+1. WSAVE(K) = 2.*SIN(FK*DT) WSAVE(KC) = 2.*COS(FK*DT) 101 CONTINUE CALL RFFTI (NM1,WSAVE(N+1)) RETURN END SUBROUTINE COST(N,X,WSAVE) C***BEGIN PROLOGUE COST C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE COSINE TRANSFORM OF A REAL, EVEN SEQUENCE. C***DESCRIPTION C C SUBROUTINE COST COMPUTES THE DISCRETE FOURIER COSINE TRANSFORM C OF AN EVEN SEQUENCE X(I). THE TRANSFORM IS DEFINED BELOW AT OUTPUT C PARAMETER X. C C COST IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF COST C FOLLOWED BY ANOTHER CALL OF COST WILL MULTIPLY THE INPUT SEQUENCE C X BY 2*(N-1). THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COST MUST BE C INITIALIZED BY CALLING SUBROUTINE COSTI(N,WSAVE). C C INPUT PARAMETERS C C N THE LENGTH OF THE SEQUENCE X. N MUST BE GREATER THAN 1. C THE METHOD IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF C SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS COST. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE COSTI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I) = X(1)+(-1)**(I-1)*X(N) C C + THE SUM FROM K=2 TO K=N-1 C C X(K)*COS((K-1)*(I-1)*PI/(N-1)) C C A CALL OF COST FOLLOWED BY ANOTHER CALL OF C COST WILL MULTIPLY THE SEQUENCE X BY 2*(N-1). C HENCE COST IS THE UNNORMALIZED INVERSE C OF ITSELF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE C DESTROYED BETWEEN CALLS OF COST. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTF C***END PROLOGUE COST DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT COST NM1 = N-1 NP1 = N+1 NS2 = N/2 IF (N-2) 106,101,102 101 X1H = X(1)+X(2) X(2) = X(1)-X(2) X(1) = X1H RETURN 102 IF (N .GT. 3) GO TO 103 X1P3 = X(1)+X(3) TX2 = X(2)+X(2) X(2) = X(1)-X(3) X(1) = X1P3+TX2 X(3) = X1P3-TX2 RETURN 103 C1 = X(1)-X(N) X(1) = X(1)+X(N) DO 104 K=2,NS2 KC = NP1-K T1 = X(K)+X(KC) T2 = X(K)-X(KC) C1 = C1+WSAVE(KC)*T2 T2 = WSAVE(K)*T2 X(K) = T1-T2 X(KC) = T1+T2 104 CONTINUE MODN = MOD(N,2) IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1) CALL RFFTF (NM1,X,WSAVE(N+1)) XIM2 = X(2) X(2) = C1 DO 105 I=4,N,2 XI = X(I) X(I) = X(I-2)-X(I-1) X(I-1) = XIM2 XIM2 = XI 105 CONTINUE IF (MODN .NE. 0) X(N) = XIM2 106 RETURN END SUBROUTINE RFFTB(N,R,WSAVE) C***BEGIN PROLOGUE RFFTB C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A1 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY. C***DESCRIPTION C C SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS C FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED C BELOW AT OUTPUT PARAMETER R. C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED. C C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15 C IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. C C C OUTPUT PARAMETERS C C R FOR N EVEN AND FOR I = 1,...,N C C R(I) = R(1)+(-1)**(I-1)*R(N) C C PLUS THE SUM FROM K=2 TO K=N/2 OF C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C FOR N ODD AND FOR I = 1,...,N C C R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C ***** NOTE: C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF C FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT C SEQUENCE BY N. C C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN C CALLS OF RFFTB OR RFFTF. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTB1 C***END PROLOGUE RFFTB DIMENSION R(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT RFFTB IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTF(N,R,WSAVE) C***BEGIN PROLOGUE RFFTF C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A1 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE FORWARD TRANSFORM OF A REAL, PERIODIC SEQUENCE. C***DESCRIPTION C C SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL C PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED C BELOW AT OUTPUT PARAMETER R. C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED C C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15 C IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. C C C OUTPUT PARAMETERS C C R R(1) = THE SUM FROM I=1 TO I=N OF R(I) C C IF N IS EVEN SET L = N/2; IF N IS ODD SET L = (N+1)/2 C C THEN FOR K = 2,...,L C C R(2*K-2) = THE SUM FROM I = 1 TO I = N OF C C R(I)*COS((K-1)*(I-1)*2*PI/N) C C R(2*K-1) = THE SUM FROM I = 1 TO I = N OF C C -R(I)*SIN((K-1)*(I-1)*2*PI/N) C C IF N IS EVEN C C R(N) = THE SUM FROM I = 1 TO I = N OF C C (-1)**(I-1)*R(I) C C ***** NOTE: C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF C FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT C SEQUENCE BY N. C C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN C CALLS OF RFFTF OR RFFTB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTF1 C***END PROLOGUE RFFTF DIMENSION R(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT RFFTF IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTI(N,WSAVE) C***BEGIN PROLOGUE RFFTI C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A1 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE INITIALIZE FOR RFFTF AND RFFTB. C***DESCRIPTION C C SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. C THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTI1 C***END PROLOGUE RFFTI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT RFFTI IF (N .EQ. 1) RETURN CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE SINQB(N,X,WSAVE) C***BEGIN PROLOGUE SINQB C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE UNNORMALIZED INVERSE OF SINQF. C***DESCRIPTION C C SUBROUTINE SINQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS, SINQB COMPUTES A SEQUENCE FROM ITS C REPRESENTATION IN TERMS OF A SINE SERIES WITH ODD WAVE NUMBERS. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. C C SINQF IS THE UNNORMALIZED INVERSE OF SINQB SINCE A CALL OF SINQB C FOLLOWED BY A CALL OF SINQF WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQB MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS SINQB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I)= THE SUM FROM K=1 TO K=N OF C C 4*X(K)*SIN((2K-1)*I*PI/(2*N)) C C A CALL OF SINQB FOLLOWED BY A CALL OF C SINQF WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE SINQF IS THE UNNORMALIZED INVERSE C OF SINQB. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF SINQB OR SINQF. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED COSQB C***END PROLOGUE SINQB DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT SINQB IF (N .GT. 1) GO TO 101 X(1) = 4.*X(1) RETURN 101 NS2 = N/2 DO 102 K=2,N,2 X(K) = -X(K) 102 CONTINUE CALL COSQB (N,X,WSAVE) DO 103 K=1,NS2 KC = N-K XHOLD = X(K) X(K) = X(KC+1) X(KC+1) = XHOLD 103 CONTINUE RETURN END SUBROUTINE SINQF(N,X,WSAVE) C***BEGIN PROLOGUE SINQF C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS. C***DESCRIPTION C C SUBROUTINE SINQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS, SINQF COMPUTES THE COEFFICIENTS IN A SINE C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM C IS DEFINED BELOW AT OUTPUT PARAMETER X. C C SINQB IS THE UNNORMALIZED INVERSE OF SINQF SINCE A CALL OF SINQF C FOLLOWED BY A CALL OF SINQB WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQF MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS SINQF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I) = (-1)**(I-1)*X(N) C C + THE SUM FROM K=1 TO K=N-1 OF C C 2*X(K)*SIN((2*I-1)*K*PI/(2*N)) C C A CALL OF SINQF FOLLOWED BY A CALL OF C SINQB WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE SINQB IS THE UNNORMALIZED INVERSE C OF SINQF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF SINQF OR SINQB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED COSQF C***END PROLOGUE SINQF DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT SINQF IF (N .EQ. 1) RETURN NS2 = N/2 DO 101 K=1,NS2 KC = N-K XHOLD = X(K) X(K) = X(KC+1) X(KC+1) = XHOLD 101 CONTINUE CALL COSQF (N,X,WSAVE) DO 102 K=2,N,2 X(K) = -X(K) 102 CONTINUE RETURN END SUBROUTINE SINQI(N,WSAVE) C***BEGIN PROLOGUE SINQI C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE INITIALIZE FOR SINQF AND SINQB. C***DESCRIPTION C C SUBROUTINE SINQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH SINQF AND SINQB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C THE SAME WORK ARRAY CAN BE USED FOR BOTH SINQF AND SINQB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF SINQF OR SINQB. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED COSQI C***END PROLOGUE SINQI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT SINQI CALL COSQI (N,WSAVE) RETURN END SUBROUTINE SINTI(N,WSAVE) C***BEGIN PROLOGUE SINTI C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE INITIALIZE FOR SINT. C***DESCRIPTION C C SUBROUTINE SINTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C SUBROUTINE SINT. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N+1 IS A PRODUCT OF SMALL PRIMES. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WITH AT LEAST INT(3.5*N+16) LOCATIONS. C DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES C OF N. THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN C CALLS OF SINT. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTI C***END PROLOGUE SINTI DIMENSION WSAVE(*) C***FIRST EXECUTABLE STATEMENT SINTI PI = 4.*ATAN(1.) IF (N .LE. 1) RETURN NP1 = N+1 NS2 = N/2 DT = PI/REAL(NP1) KS = N+2 KF = KS+NS2-1 FK = 0. DO 101 K=KS,KF FK = FK+1. WSAVE(K) = 2.*SIN(FK*DT) 101 CONTINUE CALL RFFTI (NP1,WSAVE(KF+1)) RETURN END SUBROUTINE SINT(N,X,WSAVE) C***BEGIN PROLOGUE SINT C***DATE WRITTEN 790601 (YYMMDD) C***REVISION DATE 860115 (YYMMDD) C***CATEGORY NO. J1A3 C***KEYWORDS FOURIER TRANSFORM C***AUTHOR SWARZTRAUBER, P. N., (NCAR) C***PURPOSE SINE TRANSFORM OF A REAL, ODD SEQUENCE. C***DESCRIPTION C C SUBROUTINE SINT COMPUTES THE DISCRETE FOURIER SINE TRANSFORM C OF AN ODD SEQUENCE X(I). THE TRANSFORM IS DEFINED BELOW AT C OUTPUT PARAMETER X. C C SINT IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF SINT C FOLLOWED BY ANOTHER CALL OF SINT WILL MULTIPLY THE INPUT SEQUENCE C X BY 2*(N+1). C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINT MUST BE C INITIALIZED BY CALLING SUBROUTINE SINTI(N,WSAVE). C C INPUT PARAMETERS C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N+1 IS THE PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C C WSAVE A WORK ARRAY WITH DIMENSION AT LEAST INT(3.5*N+16) C IN THE PROGRAM THAT CALLS SINT. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE SINTI(N,WSAVE), AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED. THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I)= THE SUM FROM K=1 TO K=N C C 2*X(K)*SIN(K*I*PI/(N+1)) C C A CALL OF SINT FOLLOWED BY ANOTHER CALL OF C SINT WILL MULTIPLY THE SEQUENCE X BY 2*(N+1). C HENCE SINT IS THE UNNORMALIZED INVERSE C OF ITSELF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE C DESTROYED BETWEEN CALLS OF SINT. C C ********************************************************************* C * * C * SUBPROGRAM REVISION HISTORY * C * * C * 06/01/79 - ORIGINAL VERSION BY PAUL SWARZTRAUBER. * C * DISTRIBUTED BY NCAR (REF. 1). * C * 04/01/83 - SLATEC COMMON MATH LIBRARY SUBCOMMITTEE. * C * MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. * C * DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2). * C * 01/15/86 - RON BOISVERT, NATIONAL BUREAU OF STANDARDS. * C * MODIFIED TO CONVERT TO PORTABLE FORTRAN 77. * C * * C * THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE * C * * C * (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*) * C * (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL * C * (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE- * C * MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC * C * FUNCTIONS. THE AFFECTED VARIABLES ARE * C * * C * PI SQRT2 SQRT3 TAUR TR11 TR12 * C * PIH TSQRT2 TAUI TI11 TI12 * C * TPI HSQT2 * C * * C * REFERENCES * C * * C * 1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL * C * COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982, * C * PP. 51-83. * C * 2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES * C * AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.), * C * PRENTICE-HALL, 1984, PP. 302-318. * C * * C ********************************************************************* C C***REFERENCES (NONE) C***ROUTINES CALLED RFFTF C***END PROLOGUE SINT DIMENSION X(*) ,WSAVE(*) C***FIRST EXECUTABLE STATEMENT SINT SQRT3 = SQRT(3.) IF (N-2) 101,102,103 101 X(1) = X(1)+X(1) RETURN 102 XH = SQRT3*(X(1)+X(2)) X(2) = SQRT3*(X(1)-X(2)) X(1) = XH RETURN 103 NP1 = N+1 NS2 = N/2 WSAVE(1) = 0. KW = NP1 DO 104 K=1,NS2 1 KW = KW+1 KC = NP1-K T1 = X(K)-X(KC) T2 = WSAVE(KW)*(X(K)+X(KC)) WSAVE(K+1) = T1+T2 WSAVE(KC+1) = T2-T1 104 CONTINUE MODN = MOD(N,2) IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1) NF = NP1+NS2+1 CALL RFFTF (NP1,WSAVE,WSAVE(NF)) X(1) = .5*WSAVE(1) DO 105 I=3,N,2 X(I-1) = -WSAVE(I) X(I) = X(I-2)+WSAVE(I-1) 105 CONTINUE IF (MODN .NE. 0) RETURN X(N) = -WSAVE(N+1) RETURN END SUBROUTINE COSQB1(N,X,W,XH) C***BEGIN PROLOGUE COSQB1 C***REFER TO COSQB C***ROUTINES CALLED RFFTB C***END PROLOGUE COSQB1 DIMENSION X(*) ,W(*) ,XH(*) C***FIRST EXECUTABLE STATEMENT COSQB1 NS2 = (N+1)/2 NP2 = N+2 DO 101 I=3,N,2 XIM1 = X(I-1)+X(I) X(I) = X(I)-X(I-1) X(I-1) = XIM1 101 CONTINUE X(1) = X(1)+X(1) MODN = MOD(N,2) IF (MODN .EQ. 0) X(N) = X(N)+X(N) CALL RFFTB (N,X,XH) DO 102 K=2,NS2 KC = NP2-K XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) 102 CONTINUE IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) DO 103 K=2,NS2 KC = NP2-K X(K) = XH(K)+XH(KC) X(KC) = XH(K)-XH(KC) 103 CONTINUE X(1) = X(1)+X(1) RETURN END SUBROUTINE COSQF1(N,X,W,XH) C***BEGIN PROLOGUE COSQF1 C***REFER TO COSQF C***ROUTINES CALLED RFFTF C***END PROLOGUE COSQF1 DIMENSION X(*) ,W(*) ,XH(*) C***FIRST EXECUTABLE STATEMENT COSQF1 NS2 = (N+1)/2 NP2 = N+2 DO 101 K=2,NS2 KC = NP2-K XH(K) = X(K)+X(KC) XH(KC) = X(K)-X(KC) 101 CONTINUE MODN = MOD(N,2) IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1) DO 102 K=2,NS2 KC = NP2-K X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K) X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC) 102 CONTINUE IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1) CALL RFFTF (N,X,XH) DO 103 I=3,N,2 XIM1 = X(I-1)-X(I) X(I) = X(I-1)+X(I) X(I-1) = XIM1 103 CONTINUE RETURN END SUBROUTINE RADBG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) C***BEGIN PROLOGUE RADBG C***REFER TO RFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE RADBG DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(*) C***FIRST EXECUTABLE STATEMENT RADBG TPI = 8.*ATAN(1.) ARG = TPI/REAL(IP) DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 NBD = (IDO-1)/2 IPP2 = IP+2 IPPH = (IP+1)/2 IF (IDO .LT. L1) GO TO 103 DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,1) = CC(I,1,K) 101 CONTINUE 102 CONTINUE GO TO 106 103 DO 105 I=1,IDO DO 104 K=1,L1 CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE 106 DO 108 J=2,IPPH JC = IPP2-J J2 = J+J DO 107 K=1,L1 CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) 107 CONTINUE 108 CONTINUE IF (IDO .EQ. 1) GO TO 116 IF (NBD .LT. L1) GO TO 112 DO 111 J=2,IPPH JC = IPP2-J DO 110 K=1,L1 CDIR$ IVDEP DO 109 I=3,IDO,2 IC = IDP2-I CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 109 CONTINUE 110 CONTINUE 111 CONTINUE GO TO 116 112 DO 115 J=2,IPPH JC = IPP2-J CDIR$ IVDEP DO 114 I=3,IDO,2 IC = IDP2-I DO 113 K=1,L1 CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 113 CONTINUE 114 CONTINUE 115 CONTINUE 116 AR1 = 1. AI1 = 0. DO 120 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 117 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) C2(IK,LC) = AI1*CH2(IK,IP) 117 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 119 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 118 IK=1,IDL1 C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) 118 CONTINUE 119 CONTINUE 120 CONTINUE DO 122 J=2,IPPH DO 121 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 121 CONTINUE 122 CONTINUE DO 124 J=2,IPPH JC = IPP2-J DO 123 K=1,L1 CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) 123 CONTINUE 124 CONTINUE IF (IDO .EQ. 1) GO TO 132 IF (NBD .LT. L1) GO TO 128 DO 127 J=2,IPPH JC = IPP2-J DO 126 K=1,L1 CDIR$ IVDEP DO 125 I=3,IDO,2 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE GO TO 132 128 DO 131 J=2,IPPH JC = IPP2-J DO 130 I=3,IDO,2 DO 129 K=1,L1 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 129 CONTINUE 130 CONTINUE 131 CONTINUE 132 CONTINUE IF (IDO .EQ. 1) RETURN DO 133 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 133 CONTINUE DO 135 J=2,IP DO 134 K=1,L1 C1(1,K,J) = CH(1,K,J) 134 CONTINUE 135 CONTINUE IF (NBD .GT. L1) GO TO 139 IS = -IDO DO 138 J=2,IP IS = IS+IDO IDIJ = IS DO 137 I=3,IDO,2 IDIJ = IDIJ+2 DO 136 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 136 CONTINUE 137 CONTINUE 138 CONTINUE GO TO 143 139 IS = -IDO DO 142 J=2,IP IS = IS+IDO DO 141 K=1,L1 IDIJ = IS CDIR$ IVDEP DO 140 I=3,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 140 CONTINUE 141 CONTINUE 142 CONTINUE 143 RETURN END SUBROUTINE RADB2(IDO,L1,CC,CH,WA1) C***BEGIN PROLOGUE RADB2 C***REFER TO RFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE RADB2 DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , 1 WA1(*) C***FIRST EXECUTABLE STATEMENT RADB2 DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) 106 CONTINUE 107 RETURN END SUBROUTINE RADB3(IDO,L1,CC,CH,WA1,WA2) C***BEGIN PROLOGUE RADB3 C***REFER TO RFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE RADB3 DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , 1 WA1(*) ,WA2(*) C***FIRST EXECUTABLE STATEMENT RADB3 TAUR = -.5 TAUI = .5*SQRT(3.) DO 101 K=1,L1 TR2 = CC(IDO,2,K)+CC(IDO,2,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADB4(IDO,L1,CC,CH,WA1,WA2,WA3) C***BEGIN PROLOGUE RADB4 C***REFER TO RFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE RADB4 DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , 1 WA1(*) ,WA2(*) ,WA3(*) C***FIRST EXECUTABLE STATEMENT RADB4 SQRT2 = SQRT(2.) DO 101 K=1,L1 TR1 = CC(1,1,K)-CC(IDO,4,K) TR2 = CC(1,1,K)+CC(IDO,4,K) TR3 = CC(IDO,2,K)+CC(IDO,2,K) TR4 = CC(1,3,K)+CC(1,3,K) CH(1,K,1) = TR2+TR3 CH(1,K,2) = TR1-TR4 CH(1,K,3) = TR2-TR3 CH(1,K,4) = TR1+TR4 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 TI1 = CC(1,2,K)+CC(1,4,K) TI2 = CC(1,4,K)-CC(1,2,K) TR1 = CC(IDO,1,K)-CC(IDO,3,K) TR2 = CC(IDO,1,K)+CC(IDO,3,K) CH(IDO,K,1) = TR2+TR2 CH(IDO,K,2) = SQRT2*(TR1-TI1) CH(IDO,K,3) = TI2+TI2 CH(IDO,K,4) = -SQRT2*(TR1+TI1) 106 CONTINUE 107 RETURN END SUBROUTINE RADB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4) C***BEGIN PROLOGUE RADB5 C***REFER TO RFFTB C***ROUTINES CALLED (NONE) C***END PROLOGUE RADB5 DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) C***FIRST EXECUTABLE STATEMENT RADB5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) DO 101 K=1,L1 TI5 = CC(1,3,K)+CC(1,3,K) TI4 = CC(1,5,K)+CC(1,5,K) TR2 = CC(IDO,2,K)+CC(IDO,2,K) TR3 = CC(IDO,4,K)+CC(IDO,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI5 = TI11*TI5+TI12*TI4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(1,K,5) = CR2+CI5 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADFG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) C***BEGIN PROLOGUE RADFG C***REFER TO RFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE RADFG DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(*) C***FIRST EXECUTABLE STATEMENT RADFG TPI = 8.*ATAN(1.) ARG = TPI/REAL(IP) DCP = COS(ARG) DSP = SIN(ARG) IPPH = (IP+1)/2 IPP2 = IP+2 IDP2 = IDO+2 NBD = (IDO-1)/2 IF (IDO .EQ. 1) GO TO 119 DO 101 IK=1,IDL1 CH2(IK,1) = C2(IK,1) 101 CONTINUE DO 103 J=2,IP DO 102 K=1,L1 CH(1,K,J) = C1(1,K,J) 102 CONTINUE 103 CONTINUE IF (NBD .GT. L1) GO TO 107 IS = -IDO DO 106 J=2,IP IS = IS+IDO IDIJ = IS DO 105 I=3,IDO,2 IDIJ = IDIJ+2 DO 104 K=1,L1 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 104 CONTINUE 105 CONTINUE 106 CONTINUE GO TO 111 107 IS = -IDO DO 110 J=2,IP IS = IS+IDO DO 109 K=1,L1 IDIJ = IS CDIR$ IVDEP DO 108 I=3,IDO,2 IDIJ = IDIJ+2 CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) 108 CONTINUE 109 CONTINUE 110 CONTINUE 111 IF (NBD .LT. L1) GO TO 115 DO 114 J=2,IPPH JC = IPP2-J DO 113 K=1,L1 CDIR$ IVDEP DO 112 I=3,IDO,2 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 112 CONTINUE 113 CONTINUE 114 CONTINUE GO TO 121 115 DO 118 J=2,IPPH JC = IPP2-J DO 117 I=3,IDO,2 DO 116 K=1,L1 C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) 116 CONTINUE 117 CONTINUE 118 CONTINUE GO TO 121 119 DO 120 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 120 CONTINUE 121 DO 123 J=2,IPPH JC = IPP2-J DO 122 K=1,L1 C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) 122 CONTINUE 123 CONTINUE C AR1 = 1. AI1 = 0. DO 127 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 124 IK=1,IDL1 CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) CH2(IK,LC) = AI1*C2(IK,IP) 124 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 126 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 125 IK=1,IDL1 CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE DO 129 J=2,IPPH DO 128 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+C2(IK,J) 128 CONTINUE 129 CONTINUE C IF (IDO .LT. L1) GO TO 132 DO 131 K=1,L1 DO 130 I=1,IDO CC(I,1,K) = CH(I,K,1) 130 CONTINUE 131 CONTINUE GO TO 135 132 DO 134 I=1,IDO DO 133 K=1,L1 CC(I,1,K) = CH(I,K,1) 133 CONTINUE 134 CONTINUE 135 DO 137 J=2,IPPH JC = IPP2-J J2 = J+J DO 136 K=1,L1 CC(IDO,J2-2,K) = CH(1,K,J) CC(1,J2-1,K) = CH(1,K,JC) 136 CONTINUE 137 CONTINUE IF (IDO .EQ. 1) RETURN IF (NBD .LT. L1) GO TO 141 DO 140 J=2,IPPH JC = IPP2-J J2 = J+J DO 139 K=1,L1 CDIR$ IVDEP DO 138 I=3,IDO,2 IC = IDP2-I CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 138 CONTINUE 139 CONTINUE 140 CONTINUE RETURN 141 DO 144 J=2,IPPH JC = IPP2-J J2 = J+J DO 143 I=3,IDO,2 IC = IDP2-I DO 142 K=1,L1 CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) 142 CONTINUE 143 CONTINUE 144 CONTINUE RETURN END SUBROUTINE RADF2(IDO,L1,CC,CH,WA1) C***BEGIN PROLOGUE RADF2 C***REFER TO RFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE RADF2 DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , 1 WA1(*) C***FIRST EXECUTABLE STATEMENT RADF2 DO 101 K=1,L1 CH(1,1,K) = CC(1,K,1)+CC(1,K,2) CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 109 K=1,L1 TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CH(I,1,K) = CC(I,K,1)+TI2 CH(IC,2,K) = TI2-CC(I,K,1) CH(I-1,1,K) = CC(I-1,K,1)+TR2 CH(IC-1,2,K) = CC(I-1,K,1)-TR2 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(1,2,K) = -CC(IDO,K,2) CH(IDO,1,K) = CC(IDO,K,1) 106 CONTINUE 107 RETURN END SUBROUTINE RADF3(IDO,L1,CC,CH,WA1,WA2) C***BEGIN PROLOGUE RADF3 C***REFER TO RFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE RADF3 DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , 1 WA1(*) ,WA2(*) C***FIRST EXECUTABLE STATEMENT RADF3 TAUR = -.5 TAUI = .5*SQRT(3.) DO 101 K=1,L1 CR2 = CC(1,K,2)+CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2 CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR2 = DR2+DR3 CI2 = DI2+DI3 CH(I-1,1,K) = CC(I-1,K,1)+CR2 CH(I,1,K) = CC(I,K,1)+CI2 TR2 = CC(I-1,K,1)+TAUR*CR2 TI2 = CC(I,K,1)+TAUR*CI2 TR3 = TAUI*(DI2-DI3) TI3 = TAUI*(DR3-DR2) CH(I-1,3,K) = TR2+TR3 CH(IC-1,2,K) = TR2-TR3 CH(I,3,K) = TI2+TI3 CH(IC,2,K) = TI3-TI2 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADF4(IDO,L1,CC,CH,WA1,WA2,WA3) C***BEGIN PROLOGUE RADF4 C***REFER TO RFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE RADF4 DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , 1 WA1(*) ,WA2(*) ,WA3(*) C***FIRST EXECUTABLE STATEMENT RADF4 HSQT2 = .5*SQRT(2.) DO 101 K=1,L1 TR1 = CC(1,K,2)+CC(1,K,4) TR2 = CC(1,K,1)+CC(1,K,3) CH(1,1,K) = TR1+TR2 CH(IDO,4,K) = TR2-TR1 CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) CH(1,3,K) = CC(1,K,4)-CC(1,K,2) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 111 DO 104 K=1,L1 CDIR$ IVDEP DO 103 I=3,IDO,2 IC = IDP2-I CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 103 CONTINUE 104 CONTINUE GO TO 110 111 DO 109 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 108 K=1,L1 CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) TR1 = CR2+CR4 TR4 = CR4-CR2 TI1 = CI2+CI4 TI4 = CI2-CI4 TI2 = CC(I,K,1)+CI3 TI3 = CC(I,K,1)-CI3 TR2 = CC(I-1,K,1)+CR3 TR3 = CC(I-1,K,1)-CR3 CH(I-1,1,K) = TR1+TR2 CH(IC-1,4,K) = TR2-TR1 CH(I,1,K) = TI1+TI2 CH(IC,4,K) = TI1-TI2 CH(I-1,3,K) = TI4+TR3 CH(IC-1,2,K) = TR3-TI4 CH(I,3,K) = TR4+TI3 CH(IC,2,K) = TR4-TI3 108 CONTINUE 109 CONTINUE 110 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) CH(IDO,1,K) = TR1+CC(IDO,K,1) CH(IDO,3,K) = CC(IDO,K,1)-TR1 CH(1,2,K) = TI1-CC(IDO,K,3) CH(1,4,K) = TI1+CC(IDO,K,3) 106 CONTINUE 107 RETURN END SUBROUTINE RADF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4) C***BEGIN PROLOGUE RADF5 C***REFER TO RFFTF C***ROUTINES CALLED (NONE) C***END PROLOGUE RADF5 DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) C***FIRST EXECUTABLE STATEMENT RADF5 PI = 4.*ATAN(1.) TR11 = SIN(.1*PI) TI11 = SIN(.4*PI) TR12 = -SIN(.3*PI) TI12 = SIN(.2*PI) DO 101 K=1,L1 CR2 = CC(1,K,5)+CC(1,K,2) CI5 = CC(1,K,5)-CC(1,K,2) CR3 = CC(1,K,4)+CC(1,K,3) CI4 = CC(1,K,4)-CC(1,K,3) CH(1,1,K) = CC(1,K,1)+CR2+CR3 CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 CH(1,3,K) = TI11*CI5+TI12*CI4 CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 CH(1,5,K) = TI12*CI5-TI11*CI4 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 CDIR$ IVDEP DO 102 I=3,IDO,2 IC = IDP2-I DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I CDIR$ IVDEP DO 105 K=1,L1 DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) CR2 = DR2+DR5 CI5 = DR5-DR2 CR5 = DI2-DI5 CI2 = DI2+DI5 CR3 = DR3+DR4 CI4 = DR4-DR3 CR4 = DI3-DI4 CI3 = DI3+DI4 CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 CH(I,1,K) = CC(I,K,1)+CI2+CI3 TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 TR5 = TI11*CR5+TI12*CR4 TI5 = TI11*CI5+TI12*CI4 TR4 = TI12*CR5-TI11*CR4 TI4 = TI12*CI5-TI11*CI4 CH(I-1,3,K) = TR2+TR5 CH(IC-1,2,K) = TR2-TR5 CH(I,3,K) = TI2+TI5 CH(IC,2,K) = TI5-TI2 CH(I-1,5,K) = TR3+TR4 CH(IC-1,4,K) = TR3-TR4 CH(I,5,K) = TI3+TI4 CH(IC,4,K) = TI4-TI3 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RFFTB1(N,C,CH,WA,IFAC) C***BEGIN PROLOGUE RFFTB1 C***REFER TO RFFTB C***ROUTINES CALLED RADB2,RADB3,RADB4,RADB5,RADBG C***END PROLOGUE RFFTB1 DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) C***FIRST EXECUTABLE STATEMENT RFFTB1 NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDL1 = IDO*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL RADB2 (IDO,L1,C,CH,WA(IW)) GO TO 105 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDO IF (NA .NE. 0) GO TO 107 CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 110 CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (IDO .EQ. 1) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDO 116 CONTINUE IF (NA .EQ. 0) RETURN DO 117 I=1,N C(I) = CH(I) 117 CONTINUE RETURN END SUBROUTINE RFFTF1(N,C,CH,WA,IFAC) C***BEGIN PROLOGUE RFFTF1 C***REFER TO RFFTF C***ROUTINES CALLED RADF2,RADF3,RADF4,RADF5,RADFG C***END PROLOGUE RFFTF1 DIMENSION CH(*) ,C(*) ,WA(*) ,IFAC(*) C***FIRST EXECUTABLE STATEMENT RFFTF1 NF = IFAC(2) NA = 1 L2 = N IW = N DO 111 K1=1,NF KH = NF-K1 IP = IFAC(KH+3) L1 = L2/IP IDO = N/L2 IDL1 = IDO*L1 IW = IW-(IP-1)*IDO NA = 1-NA IF (IP .NE. 4) GO TO 102 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 110 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) GO TO 110 102 IF (IP .NE. 2) GO TO 104 IF (NA .NE. 0) GO TO 103 CALL RADF2 (IDO,L1,C,CH,WA(IW)) GO TO 110 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) GO TO 110 104 IF (IP .NE. 3) GO TO 106 IX2 = IW+IDO IF (NA .NE. 0) GO TO 105 CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 110 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) GO TO 110 106 IF (IP .NE. 5) GO TO 108 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 107 CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 108 IF (IDO .EQ. 1) NA = 1-NA IF (NA .NE. 0) GO TO 109 CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) NA = 1 GO TO 110 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) NA = 0 110 L2 = L1 111 CONTINUE IF (NA .EQ. 1) RETURN DO 112 I=1,N C(I) = CH(I) 112 CONTINUE RETURN END SUBROUTINE RFFTI1(N,WA,IFAC) C***BEGIN PROLOGUE RFFTI1 C***REFER TO RFFTI C***ROUTINES CALLED (NONE) C***END PROLOGUE RFFTI1 DIMENSION WA(*) ,IFAC(*) ,NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ C***FIRST EXECUTABLE STATEMENT RFFTI1 NL = N NF = 0 J = 0 101 J = J+1 IF (J-4) 102,102,103 102 NTRY = NTRYH(J) GO TO 104 103 NTRY = NTRY+2 104 NQ = NL/NTRY NR = NL-NTRY*NQ IF (NR) 101,105,101 105 NF = NF+1 IFAC(NF+2) = NTRY NL = NQ IF (NTRY .NE. 2) GO TO 107 IF (NF .EQ. 1) GO TO 107 DO 106 I=2,NF IB = NF-I+2 IFAC(IB+2) = IFAC(IB+1) 106 CONTINUE IFAC(3) = 2 107 IF (NL .NE. 1) GO TO 104 IFAC(1) = N IFAC(2) = NF TPI = 8.*ATAN(1.) ARGH = TPI/REAL(N) IS = 0 NFM1 = NF-1 L1 = 1 IF (NFM1 .EQ. 0) RETURN DO 110 K1=1,NFM1 IP = IFAC(K1+2) LD = 0 L2 = L1*IP IDO = N/L2 IPM = IP-1 DO 109 J=1,IPM LD = LD+L1 I = IS ARGLD = REAL(LD)*ARGH FI = 0. DO 108 II=3,IDO,2 I = I+2 FI = FI+1. ARG = FI*ARGLD WA(I-1) = COS(ARG) WA(I) = SIN(ARG) 108 CONTINUE IS = IS+IDO 109 CONTINUE L1 = L2 110 CONTINUE RETURN END REAL FUNCTION R1MACH(I) C***BEGIN PROLOGUE R1MACH C***DATE WRITTEN 790101 (YYMMDD) C***REVISION DATE 831014 (YYMMDD) C***CATEGORY NO. R1 C***KEYWORDS MACHINE CONSTANTS C***AUTHOR FOX, P. A., (BELL LABS) C HALL, A. D., (BELL LABS) C SCHRYER, N. L., (BELL LABS) C***PURPOSE RETURNS SINGLE PRECISION MACHINE DEPENDENT CONSTANTS C***DESCRIPTION C C R1MACH CAN BE USED TO OBTAIN MACHINE-DEPENDENT PARAMETERS C FOR THE LOCAL MACHINE ENVIRONMENT. IT IS A FUNCTION C SUBROUTINE WITH ONE (INPUT) ARGUMENT, AND CAN BE CALLED C AS FOLLOWS, FOR EXAMPLE C C A = R1MACH(I) C C WHERE I=1,...,5. THE (OUTPUT) VALUE OF A ABOVE IS C DETERMINED BY THE (INPUT) VALUE OF I. THE RESULTS FOR C VARIOUS VALUES OF I ARE DISCUSSED BELOW. C C SINGLE-PRECISION MACHINE CONSTANTS C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. C R1MACH(5) = LOG10(B) C***REFERENCES FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR C A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE- C MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978, C PP. 177-188. C***ROUTINES CALLED (NONE) C***END PROLOGUE R1MACH C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C REAL RMACH(5) C EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA RMACH(1) / Z400800000 / C DATA RMACH(2) / Z5FFFFFFFF / C DATA RMACH(3) / Z4E9800000 / C DATA RMACH(4) / Z4EA800000 / C DATA RMACH(5) / Z500E730E8 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. C C DATA RMACH(1) / O1771000000000000 / C DATA RMACH(2) / O0777777777777777 / C DATA RMACH(3) / O1311000000000000 / C DATA RMACH(4) / O1301000000000000 / C DATA RMACH(5) / O1157163034761675 / C C C MACHINE CONSTANTS FOR THE CDC CYBER 170 SERIES (FTN5). C DATA RMACH(1) / O"00014000000000000000" / DATA RMACH(2) / O"37767777777777777777" / DATA RMACH(3) / O"16404000000000000000" / DATA RMACH(4) / O"16414000000000000000" / DATA RMACH(5) / O"17164642023241175720" / C C MACHINE CONSTANTS FOR THE CDC CYBER 200 SERIES C C DATA RMACH(1) / X'9000400000000000' / C DATA RMACH(2) / X'6FFF7FFFFFFFFFFF' / C DATA RMACH(3) / X'FFA3400000000000' / C DATA RMACH(4) / X'FFA4400000000000' / C DATA RMACH(5) / X'FFD04D104D427DE8' / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. C C DATA RMACH(1) / 00564000000000000000B / C DATA RMACH(2) / 37767777777777777776B / C DATA RMACH(3) / 16414000000000000000B / C DATA RMACH(4) / 16424000000000000000B / C DATA RMACH(5) / 17164642023241175720B / C C MACHINE CONSTANTS FOR THE CRAY 1 C C DATA RMACH(1) / 200034000000000000000B / C DATA RMACH(2) / 577767777777777777776B / C DATA RMACH(3) / 377224000000000000000B / C DATA RMACH(4) / 377234000000000000000B / C DATA RMACH(5) / 377774642023241175720B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(5) C C DATA SMALL/20K,0/,LARGE/77777K,177777K/ C DATA RIGHT/35420K,0/,DIVER/36020K,0/ C DATA LOG10/40423K,42023K/ C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '00000177 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 / C DATA DIVER(1),DIVER(2) / '20000000, '00000353 / C DATA LOG10(1),LOG10(2) / '23210115, '00000377 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. C C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 / C C MACHINE CONSTANTS FOR THE HP 2100 C C 3 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE(1), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE HP 2100 C 4 WORD DOUBLE PRECISION WITH FTN4 C C DATA SMALL(1), SMALL(2) / 40000B, 1 / C DATA LARGE91), LARGE(2) / 77777B, 177776B / C DATA RIGHT(1), RIGHT(2) / 40000B, 325B / C DATA DIVER(1), DIVER(2) / 40000B, 327B / C DATA LOG10(1), LOG10(2) / 46420B, 46777B / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86 AND C THE PERKIN ELMER (INTERDATA) 7/32. C C DATA RMACH(1) / Z00100000 / C DATA RMACH(2) / Z7FFFFFFF / C DATA RMACH(3) / Z3B100000 / C DATA RMACH(4) / Z3C100000 / C DATA RMACH(5) / Z41134413 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). C C DATA RMACH(1) / "000400000000 / C DATA RMACH(2) / "377777777777 / C DATA RMACH(3) / "146400000000 / C DATA RMACH(4) / "147400000000 / C DATA RMACH(5) / "177464202324 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 / C C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA RIGHT(1),RIGHT(2) / 13440, 0 / C DATA DIVER(1),DIVER(2) / 13568, 0 / C DATA LOG10(1),LOG10(2) / 16282, 8347 / C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA RIGHT(1),RIGHT(2) / O032200, O000000 / C DATA DIVER(1),DIVER(2) / O032400, O000000 / C DATA LOG10(1),LOG10(2) / O037632, O020233 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 / C C MACHINE CONSTANTS FOR THE VAX 11/780 C (EXPRESSED IN INTEGER AND HEXADECIMAL) C ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS*** C *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS*** C C DATA SMALL(1) / 128 / C DATA LARGE(1) / -32769 / C DATA RIGHT(1) / 13440 / C DATA DIVER(1) / 13568 / C DATA LOG10(1) / 547045274 / C C DATA SMALL(1) / Z00000080 / C DATA LARGE(1) / ZFFFF7FFF / C DATA RIGHT(1) / Z00003480 / C DATA DIVER(1) / Z00003500 / C DATA LOG10(1) / Z209B3F9A / C C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR C C DATA SMALL(1),SMALL(2) / 0, 256/ C DATA LARGE(1),LARGE(2) / -1, -129/ C DATA RIGHT(1),RIGHT(2) / 0, 26880/ C DATA DIVER(1),DIVER(2) / 0, 27136/ C DATA LOG10(1),LOG10(2) / 8347, 32538/ C C C***FIRST EXECUTABLE STATEMENT R1MACH C R1MACH = RMACH(I) RETURN C END C C EXAMPLE OF HFFT3 USAGE C C----------------------------------------------------------------------- C C PROBLEM UXX + UYY + UZZ - PI**2*U = G(X,Y) C C U = 1 ON X=0 C UX= Z*EXP(Z)+COS(2*PI*Y) ON X=1 C UZ= X ON Z=0 C U = EXP(X)+X*COS(2*PI*Y) ON Z=1 C C U(X,0,Z) = U(X,1,Z) C C G = (X**2+Z**2-PI**2)*EXP(X*Z) - 5*PI**2*X*COS(2*PI*Y) C C SOLUTION U = EXP(X*Z) + X*COS(2*PI*Y) C C----------------------------------------------------------------------- C C ------------ C DECLARATIONS C ------------ C C ... CONSTANTS C PARAMETER (NMAX=29) PARAMETER (NWORK = 3+NMAX*(7+NMAX*(11+NMAX))) PARAMETER (LDXU = NMAX+2) C C ... GLOBAL VARIABLES C COMMON /GLOBAL/ TWOPI, PISQR EXTERNAL PRHS, BRHS C C ... LOCAL VARIABLES C INTEGER BCTY(6) REAL U(LDXU,LDXU,LDXU), WORK(NWORK) C C--------------------------------------------------------------------- C PI = 4.0*ATAN(1.0) TWOPI = 2.0*PI PISQR = PI*PI C C ------------- C SETUP PROBLEM C ------------- C AX = 0.0 BX = 1.0 AY = 0.0 BY = 1.0 AZ = 0.0 BZ = 1.0 COEFU = -PISQR BCTY(1) = 2 BCTY(2) = 3 BCTY(3) = 1 BCTY(4) = 3 BCTY(5) = 1 BCTY(6) = 2 IORDER = 4 C C -------------------------- C SOLVE ON SEQUENCE OF GRIDS C -------------------------- C PRINT 2000 DO 500 N=5,29,4 NX = N NY = N NZ = N C C ... SOLVE PDE C CALL HFFT3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ, * BCTY,IORDER,U,LDXU,LDXU,WORK,NWORK,INFO) IF (INFO .LT. 0) GO TO 900 C C ... EVALUATE ERROR C H = (BX-AX)/REAL(NX-1) ERRMAX = 0.0E0 DO 100 K=1,NZ Z = AZ + REAL(K-1)*H DO 100 J=1,NY Y = AY + REAL(J-1)*H DO 100 I=1,NX X = AX + REAL(I-1)*H TRUSOL = TRUE(X,Y,Z) ERROR = ABS(TRUSOL-U(I,J,K)) ERRMAX = MAX(ERROR,ERRMAX) 100 CONTINUE PRINT 2001,N,ERRMAX 500 CONTINUE STOP C C ... ERROR EXIT C 900 CONTINUE PRINT 2002,INFO STOP C 2000 FORMAT(/' GRID MAX-ERROR' / ' -------------------' /) 2001 FORMAT(4X,I2,4X,1PE10.3) 2002 FORMAT(/' HFFT3 RETURNED INFO = ',I2) C END FUNCTION PRHS (X,Y,Z) C C ... RIGHT HAND SIDE OF PDE (USER-SUPPLIED) C COMMON /GLOBAL/ TWOPI, PISQR PRHS = (X*X+Z*Z-PISQR)*EXP(X*Z) - 5.0*PISQR*X*COS(TWOPI*Y) RETURN END FUNCTION BRHS(K,X,Y,Z) C C ... RIGHT HAND SIDE OF BOUNDARY CONDITIONS (USER-SUPPLIED) C COMMON /GLOBAL/ TWOPI, PISQR GO TO (1,2,3,4,5,6),K GO TO 999 C 1 CONTINUE BRHS = Z*EXP(Z) + COS(TWOPI*Y) GO TO 999 C 2 CONTINUE GO TO 999 C 3 CONTINUE BRHS = 1.0 GO TO 999 C 4 CONTINUE GO TO 999 C 5 CONTINUE BRHS = EXP(X) + X*COS(TWOPI*Y) GO TO 999 C 6 CONTINUE BRHS = X GO TO 999 C 999 CONTINUE RETURN END FUNCTION TRUE (X,Y,Z) COMMON /GLOBAL/ TWOPI, PISQR TRUE = EXP(X*Z) + X*COS(TWOPI*Y) RETURN END C PROGRAM TESTH3 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) C C ---------------------- C TEST DRIVER FOR HFFT3 C ---------------------- C C SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS. C USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-11). C C NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN C THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN. C ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON C A NEW COMPUTER. C C THE PROBLEMS ARE C C 1. SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION. C (PROBLEM A3 OF REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, BY=1, AZ=0, BZ=1 C C U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z) C C 2. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS; SOLUTION SAME AS IN PROBLEM 1. C (PROBLEM B3 OF REFERENCE) C C COEFU = -5 C U GIVEN ON BY=1, BZ=1 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=0 C UZ GIVEN ON AZ=0 C C U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z) C C 3. POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT C ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION C HAS DISCONTINUOUS 3RD DERIVATIVES. C C COEFU = 0 C U GIVEN ON AX=0, AY=0, AZ=0 C UX GIVEN ON BX=1 C UY GIVEN ON BY=1 C UZ GIVEN ON BZ=1 C C U = P(X)*P(Y)*P(Z) C C P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85. BETWEEN THESE C IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE C TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES. C C 4. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = -100 C U GIVEN ON BX=1, BY=1, BZ=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C UZ GIVEN ON AZ=0 C C U = (P(X;10)+P(Y;20)+P(Z;5))/3 C C P(X;A) = COSH(A*X)/COSH(A) C C 5. DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS C SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0, Z=0. C (PROBLEM F3 OF THE REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, AY=1, AZ=0, BZ=1 C C U = (X**1.5-X)*(Y**1.5-Y)*(Z**1.5-Z) C C 6. SMOOTH, PERIODIC HELMHOLTZ PROBLEM. C (PROBLEM C3 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI, AZ=0, BZ=PI C C U = COS(4Y) + SIN(4(X-Y)) + COS(4Z) C C 7. SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AZ=-1, BZ=1 C UY GIVEN ON AY=-1, BY=1 C C U = T(Y)*(A(X) + T(Y)*B(X))/2 + S(Z)*(A(X) + S(Z)*B(X))/2 C C T(Y) = 1-Y**2, S(Z) = 1-Z, A(X) = R*C(X) + EXP(SQRT(Q*X)), C B(X) = (7-P)*R/16/C(X), P = 14+SQRT(133), Q = 14-SQRT(133), C R = (7-Q)/R/SQRT(133), C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X)) C C 8. POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0, Z=0. C (PROBLEM E2 OF THE REFERNCE) C C COEFU = 0 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (X*Y)**2.5 C C 9. SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC C BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6. C (PROBLEM D2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI C U GIVEN ON AY=0, AZ=0 C UY GIVEN ON BY=PI C UZ GIVEN ON BZ=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 10. HELMHOLTZ EQUATION WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION IS CUBIC MONOMIAL; ALL METHODS SHOULD BE EXACT. C C COEFU = -5 C U GIVEN ON AY=0 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON BY=1 C UZ GIVEN ON AZ=0, BZ=1 C C U = X*Y*Z C C 11. HOMOGENEOUS NEUMANNT PROBLEM; INCLUDED TO COLLECT TIMING C DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM. C C COEFU = 0 C UX=0 ON AX=0, BX=1 C UY=0 ON AY=0, BY=1 C UZ=0 ON AZ=0, AZ=1 C C C----------------------------------------------------------------------- C C C ... CONSTANTS C C NMAX = MAX GRID SIZE FOR THIS PROGRAM C NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID C LDXU,LDYU,LDZU = REQUIRED DIMENSIONS FOR U C LUIN = INPUT UNIT FOR READS C LUOUT = OUTPUT UNIT FOR WRITES C PARAMETER (NMAX=29) PARAMETER (NWORK = 33 + NMAX*(21 + NMAX*(12 + NMAX))) PARAMETER (LDXU=NMAX+2, LDYU=NMAX+2, LDZU=NMAX+2) PARAMETER (LUIN=5, LUOUT=6) C C ... VARIABLES C INTEGER BCTY(6) REAL * COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,LDZU), * WORK(NWORK), H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE C EXTERNAL PRHS, BRHS C C C----------------------------------------------------------------------- C C C SELECT ORDER OF ACCURACY C 5 CONTINUE WRITE(LUOUT,*) 'ENTER ORDER OF ACCURACY (2 OR 4) ' READ(LUIN,*) IORDER IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 5 C C SELECT PROBLEM C 10 CONTINUE WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-11, 0 TO STOP) ' READ(LUIN,*) KPROB IF (KPROB .EQ. 0) STOP IF ((KPROB .LT. 0) .OR. (KPROB .GT. 11)) GO TO 10 C C SOLVE ON SEQUENCE OF GRIDS C WRITE(LUOUT,2000) KPROB,IORDER EOLD = 0.0E0 NRUNS = (NMAX-1)/4 NX = 1 DO 500 K=1,NRUNS C C ... SETUP PROBLEM C NX = NX + 4 CALL SETUP(KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) IF (NY .GT. NMAX) GO TO 10 IF (NZ .GT. NMAX) GO TO 10 C C ... SOLVE PROBLEM C CALL TIMER(T0) CALL HFFT3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTY, * IORDER,U,LDXU,LDYU,WORK,NWORK,INFO) CALL TIMER(T1) CPTIME = T1 - T0 C IF (INFO .LT. 0) THEN WRITE(6,2002) INFO GO TO 10 ENDIF C C ... COMPUTE ERROR C H = (BX-AX)/REAL(NX-1) CALL GETERR(AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,RELERR, * TRUMAX) C C ... COMPUTE CONVERGENCE RATE C IF (RELERR .LT. EOLD) THEN RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD)) ELSE RATE = 0.0E0 ENDIF C C ... PRINT SUMMARY C WRITE(LUOUT,2001) NX,NY,NZ,H,INFO,ABSERR,RELERR,TRUMAX,RATE, * CPTIME HOLD = H EOLD = RELERR 500 CONTINUE GO TO 10 C 2000 FORMAT(///' PROBLEM ',I2,7X,'MODULE HFFT3',7X,'IORDER = ',I1 * //' NX NY NZ',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR', * 6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,39('--') /) 2001 FORMAT(2X,I3,1X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4, * 2X,0P,F4.1,1X,F6.2) 2002 FORMAT(/' HFFT3 RETURNS INFO = ',I3 /) C END SUBROUTINE GETERR (AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR, * RELERR,TRUMAX) C C ---------------------------------------------------------- C COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID C ---------------------------------------------------------- C REAL AX,AY,AZ,H,U(LDXU,LDYU,*),ABSERR,RELERR,TRUMAX REAL X,Y,Z,TRUSOL,DIFF C ABSERR = 0.0E0 TRUMAX = 0.0E0 DO 100 K=1,NZ Z = AZ + REAL(K-1)*H DO 100 J=1,NY Y = AY + H*REAL(J-1) DO 100 I=1,NX X = AX + H*REAL(I-1) TRUSOL = TRUE(X,Y,Z) ABSERR = MAX(ABS(TRUSOL-U(I,J,K)),ABSERR) TRUMAX = MAX(ABS(TRUSOL),TRUMAX) 100 CONTINUE C IF (TRUMAX .GT. 0.0E0) THEN RELERR = ABSERR/TRUMAX ELSE RELERR = ABSERR ENDIF RETURN END SUBROUTINE SETUP (KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) C C ----------------------------------------------------------- C SETUP PROBLEM KPROB (NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) C ----------------------------------------------------------- C INTEGER KPROB,NX,NY,NZ,BCTY(6) REAL * COEFU,AX,BX,AY,BY,AZ,BZ C COMMON /SELECT/ IPROB C IPROB = KPROB C C DEFAULT VALUES C NY = NX NZ = NX AX = 0.0E0 BX = 1.0E0 AY = 0.0E0 BY = 1.0E0 AZ = 0.0E0 BZ = 1.0E0 COEFU = 0.0E0 BCTY(1) = 1 BCTY(2) = 1 BCTY(3) = 1 BCTY(4) = 1 BCTY(6) = 1 BCTY(5) = 1 C C SELECT OPTIONS FOR EACH CASE C GO TO (100,200,300,400,500,600,700,800,900,1000,1100), IPROB GO TO 9999 C 100 CONTINUE GO TO 9999 C 200 CONTINUE BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 BCTY(6) = 2 COEFU = -5.0E0 GO TO 9999 C 300 CONTINUE BCTY(1) = 2 BCTY(4) = 2 BCTY(5) = 2 GO TO 9999 C 400 CONTINUE BCTY(2) = 2 BCTY(3) = 2 BCTY(6) = 2 COEFU = -100.0E0 GO TO 9999 C 500 CONTINUE GO TO 9999 C 600 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX BZ = BX COEFU = -20.0E0 DO 605 I=1,6 BCTY(I) = 3 605 CONTINUE GO TO 9999 C 700 CONTINUE NY = 2*NX - 1 NZ = NY AY = -1.0E0 AZ = -1.0E0 BCTY(2) = 2 BCTY(4) = 2 GO TO 9999 C 800 CONTINUE BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 900 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX BZ = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(2) = 1 BCTY(3) = 3 BCTY(4) = 2 BCTY(6) = 1 BCTY(5) = 2 GO TO 9999 C 1000 CONTINUE BCTY(1) = 2 BCTY(3) = 2 BCTY(4) = 2 BCTY(6) = 2 BCTY(5) = 2 COEFU = -5.0E0 GO TO 9999 C 1100 CONTINUE BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 BCTY(4) = 2 BCTY(6) = 2 BCTY(5) = 2 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION PRHS(X,Y,Z) C C ---------------------------------------- C RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION C ---------------------------------------- C REAL X,Y,Z C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB C PRHS = 0.0E0 GO TO 9999 C 100 CONTINUE XMX2 = X*(1.0E0 - X) YMY2 = Y*(1.0E0 - Y) ZMZ2 = Z*(1.0E0 - Z) PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 + * XMX2*Y*(Y+3.0E0)*ZMZ2 + * XMX2*YMY2*Z*(Z+3.0E0) ) GO TO 9999 C 200 CONTINUE XMX2 = X*(1.0E0 - X) YMY2 = Y*(1.0E0 - Y) ZMZ2 = Z*(1.0E0 - Z) PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 + * XMX2*Y*(Y+3.0E0)*ZMZ2 + * XMX2*YMY2*Z*(Z+3.0E0) ) PRHS = PRHS - 5.0E0*TRUE(X,Y,Z) GO TO 9999 C 300 CONTINUE PRHS = D2P(X)*P(Y)*P(Z) + P(X)*D2P(Y)*P(Z) + P(X)*P(Y)*D2P(Z) GO TO 9999 C 400 CONTINUE PRHS = 100.0E0*Q(Y,20.0E0) - 25.0E0*Q(Z,5.0E0) GO TO 9999 C 500 CONTINUE C = -0.18750E0 A = 0.750E0 AM2 = A - 2.0E0 IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0) .AND. (Z .NE. 0.0E0)) THEN PRHS = C*( X**AM2*(Y**A-Y)*(Z**A-Z) * + Y**AM2*(X**A-X)*(Z**A-Z) * + Z**AM2*(X**A-X)*(Y**A-Y) ) ELSE PRHS = 0.0E0 ENDIF GO TO 9999 C 600 CONTINUE B = 4.0E0 B2 = B*B PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y)) * - (B2+20.0E0)*(COS(B*Y)+COS(B*Z)) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y Z1 = 1.0E0 - Z DEK1X = RK1*RK1*EK1X DEK2X = RK2*RK2*EK2X DEDIFF = DEK1X-DEK2X DDF1 = A*DEDIFF + DEK2X DDF2 = B*DEDIFF UXX = 0.50E0*( Y21*(DDF1+Y21*DDF2) + Z1*(DDF1+Z1*DDF2) ) UYY = -(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2) UZZ = F2 PRHS = UXX + UYY + UZZ GO TO 9999 C 800 CONTINUE PRHS= 3.750E0*(SQRT(X*(Y*Z)**5)+SQRT(Y*(X*Z)**5)+SQRT(Z*(X*Y)**5)) GO TO 9999 C 1000 CONTINUE PRHS = -5.0E0*X*Y*Z GO TO 9999 C 1100 CONTINUE PRHS = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION BRHS (K,X,Y,Z) C C -------------------------------------- C RIGHT-HAND SIDE OF BOUNDARY CONDITIONS C -------------------------------------- C REAL X,Y,Z C COMMON / SELECT / IPROB C GO TO (100,200,300,400,100,100,700,800,900,1000,1100), IPROB C 100 CONTINUE BRHS = TRUE(X,Y,Z) GO TO 9999 C 200 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN BRHS = (1.0-X-X**2)*Y*(1.0-Y)*Z*(1.0-Z)*EXP(X+Y+Z) ELSE IF (K .EQ. 2) THEN BRHS = (1.0-Y-Y**2)*X*(1.0-X)*Z*(1.0-Z)*EXP(X+Y+Z) ELSE IF (K .EQ. 6) THEN BRHS = (1.0-Z-Z**2)*X*(1.0-X)*Y*(1.0-Y)*EXP(X+Y+Z) ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 300 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 4) .OR. (K .EQ. 5)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 400 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 3) .OR. (K .EQ. 6)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 700 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 4)) THEN S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X BRHS = -Y*F1 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 800 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 3)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 900 CONTINUE B = 4.0E0 IF ((K .EQ. 2) .OR. (K .EQ. 6)) THEN BRHS = TRUE(X,Y,Z) ELSE IF (K .EQ. 4) THEN BRHS = -B*( SIN(B*Y) + COS(B*(X-Y)) ) ELSE BRHS = -B*SIN(B*Z) ENDIF GO TO 9999 C 1000 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN BRHS = Y*Z ELSE IF (K .EQ. 4) THEN BRHS = X*Z ELSE IF ((K .EQ. 5) .OR. (K .EQ. 6)) THEN BRHS = X*Y ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 1100 CONTINUE BRHS = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION TRUE(X,Y,Z) C C ------------- C TRUE SOLUTION C ------------- C REAL X,Y,Z C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB C TRUE = 0.0E0 GO TO 9999 C 100 CONTINUE TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z) GO TO 9999 C 200 CONTINUE TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z) GO TO 9999 C 300 CONTINUE TRUE = P(X)*P(Y)*P(Z) GO TO 9999 C 400 CONTINUE TRUE = ( Q(X,10.0E0) + Q(Y,20.0E0) + Q(Z,5.0E0) )/3.0E0 GO TO 9999 C 500 CONTINUE A = 0.750E0 TRUE = (X**A-X)*(Y**A-Y)*(Z**A-Z) GO TO 9999 C 600 CONTINUE B = 4.0E0 TRUE = COS(B*Y) + SIN(B*(X-Y)) + COS(B*Z) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y Z1 = 1.0E0 - Z TRUE = 0.50E0*( Y21*(F1 + Y21*F2) + Z1*(F1 + Z1*F2) ) GO TO 9999 C 800 CONTINUE TRUE = SQRT((X*Y*Z)**5) GO TO 9999 C 1000 CONTINUE TRUE = X*Y*Z GO TO 9999 C 1100 CONTINUE TRUE = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 20 DZ = Z2 - Z1 P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ * + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3 RETURN 10 CONTINUE P = 1.0E0 RETURN 20 CONTINUE P = 0.0E0 RETURN END REAL FUNCTION D2P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 10 DZ = Z2 - Z1 C3 = -1.0E0/DZ**3 C4 = 3.0E0/DZ**4 C5 = -6.0E0/DZ**5 ZMZ1 = Z - Z1 ZMZ2 = Z - Z2 ZMZ12 = ZMZ1*ZMZ1 ZMZ22 = ZMZ2*ZMZ2 D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22 * + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1 RETURN 10 CONTINUE D2P = 0.0E0 RETURN END REAL FUNCTION Q (Z,A) Q = COSH(A*Z)/COSH(A) RETURN END SUBROUTINE TIMER (T) C C ------------------------------------------------ C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) C ------------------------------------------------ C REAL T T = SECOND() RETURN END C PROGRAM TEST2 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) C C --------------------- C TEST DRIVER FOR HFFT2 C --------------------- C C SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS. C USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-10). C C NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN C THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN. C ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON C A NEW COMPUTER. C C THE PROBLEMS ARE C C 1. SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION. C (PROBLEM A2 OF REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, BY=1 C C U = 3XY(1-X)(1-Y) EXP(X+Y) C C 2. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS; SOLUTION SAME AS IN PROBLEM 1. C (PROBLEM B2 OF REFERENCE) C C COEFU = -5 C U GIVEN ON BY=1 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=0 C C U = 3XY(1-X)(1-Y) EXP(X+Y) C C 3. POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT C ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION C HAS DISCONTINUOUS 3RD DERIVATIVES. C C COEFU = 0 C U GIVEN ON AX=0, AY=0 C UX GIVEN ON BX=1 C UY GIVEN ON BY=1 C C U = P(X)*P(Y) C C P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85. BETWEEN THESE C IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE C TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES. C C 4. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = -100 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (P(X;10)+P(Y;20)/2 C C P(X;A) = COSH(A*X)/COSH(A) C C 5. DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS C SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0. C (PROBLEM F2 OF THE REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, AY=1 C C U = (X**1.5-X)*(Y**1.5-Y) C C 6. SMOOTH, PERIODIC HELMHOLTZ PROBLEM. C (PROBLEM C2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 7. SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = 0 C U GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=-1, BY=1 C C U = T(Y)*( A(X) + T(Y)*B(X) ) C C T(Y) = 1-Y**2, A(X) = R*C(X) + EXP(SQRT(Q*X)), C B(X) = (7-P)*R/16/C(X), P = 14+SQRT(133), Q = 14-SQRT(133), C R = (7-Q)/R/SQRT(133), C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X)) C C 8. POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0. C (PROBLEM E2 OF THE REFERNCE) C C COEFU = 0 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (X*Y)**2.5 C C 9. SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC C BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6. C (PROBLEM D2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI C U GIVEN ON AY=0 C UY GIVEN ON BY=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 10. HOMOGENEOUS DIRICHLET PROBLEM; INCLUDED TO COLLECT TIMING C DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM. C C COEFU = 0 C U=0 ON AX=0, BX=1, AY=0, BY=1 C C C----------------------------------------------------------------------- C C C ... CONSTANTS C C NMAX = MAX GRID SIZE FOR THIS PROGRAM C NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID C LDXU,LDYU = REQUIRED DIMENSIONS FOR U C LUIN = INPUT UNIT FOR READS C LUOUT = OUTPUT UNIT FOR WRITES C PARAMETER (NRUNS=7,NMAX=2**NRUNS+1) PARAMETER (NWORK= (NMAX+1)**2 + 14*NMAX + NMAX/2 + 15) PARAMETER (LDXU=NMAX+2,LDYU=NMAX+2) PARAMETER (LUIN=5, LUOUT=6) C C ... VARIABLES C INTEGER BCTY(4) REAL * COEFU, AX, BX, AY, BY, U(LDXU,LDYU), WORK(NWORK), * H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE C EXTERNAL PRHS, BRHS C C C----------------------------------------------------------------------- C C C SELECT ORDER OF ACCURACY C 5 CONTINUE WRITE(LUOUT,*) ' ENTER ORDER OF ACCURACY (2 OR 4) ' READ(LUIN,*) IORDER IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 5 C C SELECT PROBLEM C 10 CONTINUE WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-10, 0 TO STOP) ' READ(LUIN,*) KPROB IF (KPROB .EQ. 0) STOP IF ((KPROB .LT. 0) .OR. (KPROB .GT. 10)) GO TO 10 C C SOLVE ON SEQUENCE OF GRIDS C WRITE(LUOUT,2000) KPROB,IORDER EOLD = 0.0E0 DO 500 K=2,NRUNS C C ... SETUP PROBLEM KPROB C NX = 2**K + 1 CALL SETUP(KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY) IF (NY .GT. NMAX) GO TO 10 C C ... SOLVE PROBLEM C CALL TIMER(T0) CALL HFFT2(COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER, * U,LDXU,WORK,NWORK,INFO) CALL TIMER(T1) CPTIME = T1 - T0 C IF (INFO .LT. 0) THEN WRITE(LUOUT,2002) INFO GO TO 10 ENDIF C C ... COMPUTE ERROR C H = (BX-AX)/REAL(NX-1) CALL GETERR(AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX) C C ... COMPUTE CONVERGENCE RATE C IF (RELERR .LT. EOLD) THEN RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD)) ELSE RATE = 0.0E0 ENDIF C C ... PRINT SUMMARY C WRITE(LUOUT,2001) NX,NY,H,INFO,ABSERR,RELERR,TRUMAX,RATE,CPTIME HOLD = H EOLD = RELERR 500 CONTINUE GO TO 10 C 2000 FORMAT(///' PROBLEM ',I2,7X,'MODULE HFFT2',7X,'IORDER = ',I1 * //' NX NY',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR', * 6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,37('--') /) 2001 FORMAT(2X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,2X,0P,F4.1,1X,F6.2) 2002 FORMAT(/' HFFT2 RETURNS INFO = ',I3) C END SUBROUTINE GETERR (AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX) C C ---------------------------------------------------------- C COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID C ---------------------------------------------------------- C REAL AX,AY,H,U(LDXU,*),ABSERR,RELERR,TRUMAX REAL X,Y,TRUSOL,DIFF C ABSERR = 0.0E0 TRUMAX = 0.0E0 DO 100 J=1,NY Y = AY + H*REAL(J-1) DO 100 I=1,NX X = AX + H*REAL(I-1) TRUSOL = TRUE(X,Y) ABSERR = MAX(ABS(TRUSOL-U(I,J)),ABSERR) TRUMAX = MAX(ABS(TRUSOL),TRUMAX) 100 CONTINUE C IF (TRUMAX .NE. 0.0E0) THEN RELERR = ABSERR/TRUMAX ELSE RELERR = ABSERR ENDIF RETURN END SUBROUTINE SETUP (KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY) C C --------------------------------------------------------- C SETUP PROBLEM KPROB (NX, NY, COEFU, AX, BX, AY, BY, BCTY) C --------------------------------------------------------- C INTEGER KPROB,NX,NY,BCTY(4) REAL * COEFU,AX,BX,AY,BY C COMMON /SELECT/ IPROB C IPROB = KPROB C C DEFAULT VALUES C NY = NX AX = 0.0E0 BX = 1.0E0 AY = 0.0E0 BY = 1.0E0 COEFU = 0.0E0 BCTY(1) = 1 BCTY(2) = 1 BCTY(3) = 1 BCTY(4) = 1 C C SELECT OPTIONS FOR EACH CASE C GO TO (100,200,300,400,500,600,700,800,900), IPROB GO TO 9999 C 100 CONTINUE GO TO 9999 C 200 CONTINUE COEFU = -5.0E0 BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 300 CONTINUE BCTY(1) = 2 BCTY(4) = 2 GO TO 9999 C 400 CONTINUE COEFU = -100.0E0 BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 500 CONTINUE GO TO 9999 C 600 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(2) = 3 BCTY(3) = 3 BCTY(4) = 3 GO TO 9999 C 700 CONTINUE NY = 2*NX - 1 AY = -1.0E0 BCTY(2) = 2 BCTY(4) = 2 GO TO 9999 C 800 CONTINUE BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 900 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(4) = 2 BCTY(3) = 3 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION PRHS(X,Y) C C ---------------------------------------- C RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION C ---------------------------------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600), IPROB C PRHS = 0.0E0 GO TO 9999 C 100 CONTINUE PRHS = 6.0E0*X*Y*EXP(X+Y)*(X*Y+X+Y-3.) GO TO 9999 C 200 CONTINUE PRHS = X*Y*EXP(X+Y)*(6.0E0*(X*Y+X+Y-3.0E0) * - 15.0E0*(1.0E0-X)*(1.0E0-Y)) GO TO 9999 C 300 CONTINUE PRHS = D2P(X)*P(Y) + P(X)*D2P(Y) GO TO 9999 C 400 CONTINUE PRHS = 150.0E0*COSH(20.0E0*Y)/COSH(20.0E0) GO TO 9999 C 500 CONTINUE C = -0.18750E0 A = 0.750E0 AM2 = A - 2.0E0 IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0)) THEN PRHS = C*(X**AM2*(Y**A-Y) + Y**AM2*(X**A-X)) ELSE PRHS = 0.0E0 ENDIF GO TO 9999 C 600 CONTINUE B = 4.0E0 B2 = B*B PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y)) * - (B2+20.0E0)*COS(B*Y) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y DEK1X = RK1*RK1*EK1X DEK2X = RK2*RK2*EK2X DEDIFF = DEK1X-DEK2X DDF1 = A*DEDIFF + DEK2X DDF2 = B*DEDIFF UXX = Y21*(DDF1 + Y21*DDF2) UYY = -2.0E0*(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2) PRHS = UXX + UYY GO TO 9999 C 800 CONTINUE PRHS = 3.750E0*(SQRT(X*Y**5) + SQRT(Y*X**5)) GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION BRHS (K,X,Y) C C -------------------------------------- C RIGHT-HAND SIDE OF BOUNDARY CONDITIONS C -------------------------------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,900), IPROB C BRHS = 0.0E0 GO TO 9999 C 100 CONTINUE BRHS = 0.0E0 GO TO 9999 C 200 CONTINUE GO TO (210,220,210,240), K 210 BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*X)*Y*(1.0E0-Y) GO TO 9999 220 BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*Y)*X*(1.0E0-X) GO TO 9999 240 BRHS = 0.0E0 GO TO 9999 C 300 CONTINUE GO TO (310,320,320,310), K 310 BRHS = 0.0E0 GO TO 9999 320 BRHS = TRUE(X,Y) GO TO 9999 C 400 CONTINUE GO TO (420,410,410,420), K 410 BRHS = 0.0E0 GO TO 9999 420 BRHS = TRUE(X,Y) GO TO 9999 C 500 CONTINUE BRHS = TRUE(X,Y) GO TO 9999 C 600 CONTINUE GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y GO TO (710,720,710,720), K 710 BRHS = Y21*(F1 + Y21*F2) GO TO 9999 720 BRHS = -2.0E0*Y*(F1 + 2.0E0*Y21*F2) GO TO 9999 C 800 CONTINUE GO TO (810,820,820,810), K 810 BRHS = SQRT((X*Y)**5) GO TO 9999 820 BRHS = 0.0E0 GO TO 9999 C 900 CONTINUE IF (K .EQ. 2) THEN BRHS = TRUE(X,Y) ELSE BRHS = -4.0E0*COS(4.0E0*X) ENDIF GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION TRUE(X,Y) C C ------------- C TRUE SOLUTION C ------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,100,300,400,500,600,700,800,600), IPROB C TRUE = 0.0E0 GO TO 9999 C 100 CONTINUE TRUE = 3.0E0*EXP(X+Y)*X*Y*(1.0E0-X)*(1.0E0-Y) GO TO 9999 C 300 CONTINUE TRUE = P(X)*P(Y) GO TO 9999 C 400 CONTINUE TRUE = (COSH(10.E0*X)/COSH(10.0E0)+COSH(20.0E0*Y)/COSH(20.0E0)) * /2.0E0 GO TO 9999 C 500 CONTINUE A = 0.750E0 TRUE = (X**A-X)*(Y**A-Y) GO TO 9999 C 600 CONTINUE B = 4.0E0 TRUE = COS(B*Y) + SIN(B*(X-Y)) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y TRUE = Y21*(F1 + Y21*F2) GO TO 9999 C 800 CONTINUE TRUE = SQRT((X*Y)**5) GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 20 DZ = Z2 - Z1 P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ * + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3 RETURN 10 CONTINUE P = 1.0E0 RETURN 20 CONTINUE P = 0.0E0 RETURN END REAL FUNCTION D2P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 10 DZ = Z2 - Z1 C3 = -1.0E0/DZ**3 C4 = 3.0E0/DZ**4 C5 = -6.0E0/DZ**5 ZMZ1 = Z - Z1 ZMZ2 = Z - Z2 ZMZ12 = ZMZ1*ZMZ1 ZMZ22 = ZMZ2*ZMZ2 D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22 * + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1 RETURN 10 CONTINUE D2P = 0.0E0 RETURN END SUBROUTINE TIMER (T) C C ------------------------------------------------ C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) C ------------------------------------------------ C REAL T T = SECOND() RETURN END C PROGRAM TESTF3 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) C C ---------------------- C TEST DRIVER FOR HW3CRT C ---------------------- C C SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS. C USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-11). C C NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN C THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN. C ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON C A NEW COMPUTER. C C THE PROBLEMS ARE C C 1. SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION. C (PROBLEM A3 OF REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, BY=1, AZ=0, BZ=1 C C U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z) C C 2. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS; SOLUTION SAME AS IN PROBLEM 1. C (PROBLEM B3 OF REFERENCE) C C COEFU = -5 C U GIVEN ON BY=1, BZ=1 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=0 C UZ GIVEN ON AZ=0 C C U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z) C C 3. POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT C ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION C HAS DISCONTINUOUS 3RD DERIVATIVES. C C COEFU = 0 C U GIVEN ON AX=0, AY=0, AZ=0 C UX GIVEN ON BX=1 C UY GIVEN ON BY=1 C UZ GIVEN ON BZ=1 C C U = P(X)*P(Y)*P(Z) C C P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85. BETWEEN THESE C IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE C TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES. C C 4. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = -100 C U GIVEN ON BX=1, BY=1, BZ=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C UZ GIVEN ON AZ=0 C C U = (P(X;10)+P(Y;20)+P(Z;5))/3 C C P(X;A) = COSH(A*X)/COSH(A) C C 5. DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS C SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0, Z=0. C (PROBLEM F3 OF THE REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, AY=1, AZ=0, BZ=1 C C U = (X**1.5-X)*(Y**1.5-Y)*(Z**1.5-Z) C C 6. SMOOTH, PERIODIC HELMHOLTZ PROBLEM. C (PROBLEM C3 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI, AZ=0, BZ=PI C C U = COS(4Y) + SIN(4(X-Y)) + COS(4Z) C C 7. SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AZ=-1, BZ=1 C UY GIVEN ON AY=-1, BY=1 C C U = T(Y)*(A(X) + T(Y)*B(X))/2 + S(Z)*(A(X) + S(Z)*B(X))/2 C C T(Y) = 1-Y**2, S(Z) = 1-Z, A(X) = R*C(X) + EXP(SQRT(Q*X)), C B(X) = (7-P)*R/16/C(X), P = 14+SQRT(133), Q = 14-SQRT(133), C R = (7-Q)/R/SQRT(133), C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X)) C C 8. POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0, Z=0. C (PROBLEM E2 OF THE REFERNCE) C C COEFU = 0 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (X*Y)**2.5 C C 9. SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC C BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6. C (PROBLEM D2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI C U GIVEN ON AY=0, AZ=0 C UY GIVEN ON BY=PI C UZ GIVEN ON BZ=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 10. HELMHOLTZ EQUATION WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION IS CUBIC MONOMIAL; ALL METHODS SHOULD BE EXACT. C C COEFU = -5 C U GIVEN ON AY=0 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON BY=1 C UZ GIVEN ON AZ=0, BZ=1 C C U = X*Y*Z C C 11. HOMOGENEOUS NEUMANNT PROBLEM; INCLUDED TO COLLECT TIMING C DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM. C C COEFU = 0 C UX=0 ON AX=0, BX=1 C UY=0 ON AY=0, BY=1 C UZ=0 ON AZ=0, AZ=1 C C C----------------------------------------------------------------------- C C C ... CONSTANTS C C NMAX = MAX GRID SIZE FOR THIS PROGRAM C NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID C LDXU = REQUIRED DIMENSION FOR U C LUIN = INPUT UNIT FOR READS C LUOUT = OUTPUT UNIT FOR WRITES C PARAMETER (NMAX=29) PARAMETER (NWORK= 2*NMAX**3 + 6*NMAX**2 + 7*NMAX + NMAX/2 + 15) PARAMETER (LDXU=NMAX, LDYU=NMAX, LDZU=NMAX) PARAMETER (LUIN=5, LUOUT=6) C C ... VARIABLES C INTEGER BCTY(6) REAL * COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,LDZU), * WORK(NWORK), H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE C EXTERNAL PRHS, BRHS C C C----------------------------------------------------------------------- C C C SELECT PROBLEM C 10 CONTINUE WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-11, 0 TO STOP) ' READ(LUIN,*) KPROB IF (KPROB .EQ. 0) STOP IF ((KPROB .LT. 0) .OR. (KPROB .GT. 11)) GO TO 10 C C SOLVE ON SEQUENCE OF GRIDS C WRITE(LUOUT,2000) KPROB EOLD = 0.0E0 NRUNS = 6 NX = 5 DO 500 K=1,NRUNS C C ... SETUP PROBLEM C NX = NX + 4 CALL SETUP(KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) IF (NY .GT. NMAX) GO TO 10 IF (NZ .GT. NMAX) GO TO 10 C C ... SOLVE PROBLEM C CALL TIMER(T0) CALL FISH3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTY, * U,LDXU,LDYU,WORK,NWORK,INFO) CALL TIMER(T1) CPTIME = T1 - T0 C IF (INFO .NE. 0) THEN WRITE(LUOUT,2002) INFO GO TO 10 ENDIF C C ... COMPUTE ERROR C H = (BX-AX)/REAL(NX-1) CALL GETERR(AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,RELERR, * TRUMAX) C C ... COMPUTE CONVERGENCE RATE C IF (RELERR .LT. EOLD) THEN RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD)) ELSE RATE = 0.0E0 ENDIF C C ... PRINT SUMMARY C WRITE(LUOUT,2001) NX,NY,NZ,H,INFO,ABSERR,RELERR,TRUMAX,RATE, * CPTIME HOLD = H EOLD = RELERR 500 CONTINUE GO TO 10 C 2000 FORMAT(///' PROBLEM ',I2,7X,'MODULE HW3CRT' * //' NX NY NZ',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR', * 6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,39('--') /) 2001 FORMAT(2X,I3,1X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4, * 2X,0P,F4.1,1X,F6.2) 2002 FORMAT(/' HW3CRT RETURNS INFO = ',I3/) C END SUBROUTINE FISH3 (COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ, * BCTY,U,LDXU,LDYU,WORK,NWORK,INFO) C C----------------------------------------------------------------------- C C DRIVER FOR FISHPAK SUBPROGRAM HW3CRT C C----------------------------------------------------------------------- C INTEGER NX, NY, NZ, BCTY(6), LDXU, LDYU, NWORK, INFO REAL * COEFU, PRHS, BRHS, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,*), * WORK(NWORK) REAL * H, X(100), Y(100), Z(100), PERTRB C C-------------------------------------------------------------------- C L = NX-1 M = NY-1 N = NZ-1 H = (BX-AX)/REAL(L) C KBCA = BCTY(3) KBCB = BCTY(1) KBCC = BCTY(2) KBCD = BCTY(4) KBCE = BCTY(6) KBCF = BCTY(5) IF ((KBCA .EQ. 3) .AND. (KBCB .EQ. 3)) LBDCND = 0 IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 1)) LBDCND = 1 IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 2)) LBDCND = 2 IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 2)) LBDCND = 3 IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 1)) LBDCND = 4 IF ((KBCC .EQ. 3) .AND. (KBCD .EQ. 3)) MBDCND = 0 IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 1)) MBDCND = 1 IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 2)) MBDCND = 2 IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 2)) MBDCND = 3 IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 1)) MBDCND = 4 IF ((KBCE .EQ. 3) .AND. (KBCF .EQ. 3)) NBDCND = 0 IF ((KBCE .EQ. 1) .AND. (KBCF .EQ. 1)) NBDCND = 1 IF ((KBCE .EQ. 1) .AND. (KBCF .EQ. 2)) NBDCND = 2 IF ((KBCE .EQ. 2) .AND. (KBCF .EQ. 2)) NBDCND = 3 IF ((KBCE .EQ. 2) .AND. (KBCF .EQ. 1)) NBDCND = 4 C C COMPUTE GRID POINTS C DO 10 I=1,NX X(I) = AX + REAL(I-1)*H 10 CONTINUE DO 20 J=1,NY Y(J) = AY + REAL(J-1)*H 20 CONTINUE DO 30 K=1,NZ Z(K) = AZ + REAL(K-1)*H 30 CONTINUE X(NX) = BX Y(NY) = BY Z(NZ) = BZ C C LOAD RHS OF HELMHOLTZ EQUATION C DO 50 K=1,NZ DO 50 J=1,NY DO 50 I=1,NX U(I,J,K) = PRHS(X(I),Y(J),Z(K)) 50 CONTINUE C C LOAD DIRICHLET BOUNDARY VALUES C IF (KBCA .EQ. 1) THEN DO 110 K=1,NZ DO 110 J=1,NY U(1,J,K) = BRHS(3,X(1),Y(J),Z(K)) 110 CONTINUE ENDIF C IF (KBCB .EQ. 1) THEN DO 120 K=1,NZ DO 120 J=1,NY U(NX,J,K) = BRHS(1,X(NX),Y(J),Z(K)) 120 CONTINUE ENDIF C IF (KBCC .EQ. 1) THEN DO 130 K=1,NZ DO 130 I=1,NX U(I,1,K) = BRHS(2,X(I),Y(1),Z(K)) 130 CONTINUE ENDIF C IF (KBCD .EQ. 1) THEN DO 140 K=1,NZ DO 140 I=1,NX U(I,NY,K) = BRHS(4,X(I),Y(NY),Z(K)) 140 CONTINUE ENDIF C IF (KBCE .EQ. 1) THEN DO 150 J=1,NY DO 150 I=1,NX U(I,J,1) = BRHS(6,X(I),Y(J),Z(1)) 150 CONTINUE ENDIF C IF (KBCF .EQ. 1) THEN DO 160 J=1,NY DO 160 I=1,NX U(I,J,NZ) = BRHS(5,X(I),Y(J),Z(NZ)) 160 CONTINUE ENDIF C C PARTITION WORK ARRAY C LOC BDA = 1 LOC BDB = LOC BDA + LDYU*NZ LOC BDC = LOC BDB + LDYU*NZ LOC BDD = LOC BDC + LDXU*NZ LOC BDE = LOC BDD + LDXU*NZ LOC BDF = LOC BDE + LDXU*NY LOC WRK = LOC BDF + LDXU*NY C C LOAD NEUMANN BOUNDARY VALUES C IF (KBCA .EQ. 2) THEN DO 210 K=1,NZ LOC = LOC BDA + (K-1)*LDYU - 1 DO 210 J=1,NY LOC = LOC + 1 WORK(LOC) = BRHS(3,X(1),Y(J),Z(K)) 210 CONTINUE ENDIF C IF (KBCB .EQ. 2) THEN DO 220 K=1,NZ LOC = LOC BDB + (K-1)*LDYU - 1 DO 220 J=1,NY LOC = LOC + 1 WORK(LOC) = BRHS(1,X(NX),Y(J),Z(K)) 220 CONTINUE ENDIF C IF (KBCC .EQ. 2) THEN DO 230 K=1,NZ LOC = LOC BDC + (K-1)*LDXU - 1 DO 230 I=1,NX LOC = LOC + 1 WORK(LOC) = BRHS(2,X(I),Y(1),Z(K)) 230 CONTINUE ENDIF C IF (KBCD .EQ. 2) THEN DO 240 K=1,NZ LOC = LOC BDD + (K-1)*LDXU - 1 DO 240 I=1,NX LOC = LOC + 1 WORK(LOC) = BRHS(4,X(I),Y(NY),Z(K)) 240 CONTINUE ENDIF C IF (KBCE .EQ. 2) THEN DO 250 J=1,NY LOC = LOC BDE + (J-1)*LDXU - 1 DO 250 I=1,NX LOC = LOC + 1 WORK(LOC) = BRHS(6,X(I),Y(J),Z(1)) 250 CONTINUE ENDIF C IF (KBCF .EQ. 2) THEN DO 260 J=1,NY LOC = LOC BDF + (J-1)*LDXU - 1 DO 260 I=1,NX LOC = LOC + 1 WORK(LOC) = BRHS(5,X(I),Y(J),Z(NZ)) 260 CONTINUE ENDIF C C CALL HW3CRT(AX,BX,L,LBDCND,WORK(LOCBDA),WORK(LOCBDB), * AY,BY,M,MBDCND,WORK(LOCBDC),WORK(LOCBDD), * AZ,BZ,N,NBDCND,WORK(LOCBDE),WORK(LOCBDF), * COEFU,LDXU,LDYU,U,PERTRB,INFO,WORK(LOCWRK)) C RETURN END SUBROUTINE GETERR (AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR, * RELERR,TRUMAX) C C ---------------------------------------------------------- C COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID C ---------------------------------------------------------- C REAL AX,AY,AZ,H,U(LDXU,LDYU,*),ABSERR,RELERR,TRUMAX REAL X,Y,Z,TRUSOL,DIFF C ABSERR = 0.0E0 TRUMAX = 0.0E0 DO 100 K=1,NZ Z = AZ + REAL(K-1)*H DO 100 J=1,NY Y = AY + H*REAL(J-1) DO 100 I=1,NX X = AX + H*REAL(I-1) TRUSOL = TRUE(X,Y,Z) ABSERR = MAX(ABS(TRUSOL-U(I,J,K)),ABSERR) TRUMAX = MAX(ABS(TRUSOL),TRUMAX) 100 CONTINUE C IF (TRUMAX .GT. 0.0E0) THEN RELERR = ABSERR/TRUMAX ELSE RELERR = ABSERR ENDIF RETURN END SUBROUTINE SETUP (KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) C C ----------------------------------------------------------- C SETUP PROBLEM KPROB (NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY) C ----------------------------------------------------------- C INTEGER KPROB,NX,NY,NZ,BCTY(6) REAL * COEFU,AX,BX,AY,BY,AZ,BZ C COMMON /SELECT/ IPROB C IPROB = KPROB C C DEFAULT VALUES C NY = NX NZ = NX AX = 0.0E0 BX = 1.0E0 AY = 0.0E0 BY = 1.0E0 AZ = 0.0E0 BZ = 1.0E0 COEFU = 0.0E0 BCTY(1) = 1 BCTY(2) = 1 BCTY(3) = 1 BCTY(4) = 1 BCTY(6) = 1 BCTY(5) = 1 C C SELECT OPTIONS FOR EACH CASE C GO TO (100,200,300,400,500,600,700,800,900,1000,1100), IPROB GO TO 9999 C 100 CONTINUE GO TO 9999 C 200 CONTINUE BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 BCTY(6) = 2 COEFU = -5.0E0 GO TO 9999 C 300 CONTINUE BCTY(1) = 2 BCTY(4) = 2 BCTY(5) = 2 GO TO 9999 C 400 CONTINUE BCTY(2) = 2 BCTY(3) = 2 BCTY(6) = 2 COEFU = -100.0E0 GO TO 9999 C 500 CONTINUE GO TO 9999 C 600 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX BZ = BX COEFU = -20.0E0 DO 605 I=1,6 BCTY(I) = 3 605 CONTINUE GO TO 9999 C 700 CONTINUE NY = 2*NX - 1 NZ = NY AY = -1.0E0 AZ = -1.0E0 BCTY(2) = 2 BCTY(4) = 2 GO TO 9999 C 800 CONTINUE BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 900 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX BZ = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(2) = 1 BCTY(3) = 3 BCTY(4) = 2 BCTY(6) = 1 BCTY(5) = 2 GO TO 9999 C 1000 CONTINUE BCTY(1) = 2 BCTY(3) = 2 BCTY(4) = 2 BCTY(6) = 2 BCTY(5) = 2 COEFU = -5.0E0 GO TO 9999 C 1100 CONTINUE BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 BCTY(4) = 2 BCTY(6) = 2 BCTY(5) = 2 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION PRHS(X,Y,Z) C C ---------------------------------------- C RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION C ---------------------------------------- C REAL X,Y,Z C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB C PRHS = 0.0E0 GO TO 9999 C 100 CONTINUE XMX2 = X*(1.0E0 - X) YMY2 = Y*(1.0E0 - Y) ZMZ2 = Z*(1.0E0 - Z) PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 + * XMX2*Y*(Y+3.0E0)*ZMZ2 + * XMX2*YMY2*Z*(Z+3.0E0) ) GO TO 9999 C 200 CONTINUE XMX2 = X*(1.0E0 - X) YMY2 = Y*(1.0E0 - Y) ZMZ2 = Z*(1.0E0 - Z) PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 + * XMX2*Y*(Y+3.0E0)*ZMZ2 + * XMX2*YMY2*Z*(Z+3.0E0) ) PRHS = PRHS - 5.0E0*TRUE(X,Y,Z) GO TO 9999 C 300 CONTINUE PRHS = D2P(X)*P(Y)*P(Z) + P(X)*D2P(Y)*P(Z) + P(X)*P(Y)*D2P(Z) GO TO 9999 C 400 CONTINUE PRHS = 100.0E0*Q(Y,20.0E0) - 25.0E0*Q(Z,5.0E0) GO TO 9999 C 500 CONTINUE C = -0.18750E0 A = 0.750E0 AM2 = A - 2.0E0 IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0) .AND. (Z .NE. 0.0E0)) THEN PRHS = C*( X**AM2*(Y**A-Y)*(Z**A-Z) * + Y**AM2*(X**A-X)*(Z**A-Z) * + Z**AM2*(X**A-X)*(Y**A-Y) ) ELSE PRHS = 0.0E0 ENDIF GO TO 9999 C 600 CONTINUE B = 4.0E0 B2 = B*B PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y)) * - (B2+20.0E0)*(COS(B*Y)+COS(B*Z)) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y Z1 = 1.0E0 - Z DEK1X = RK1*RK1*EK1X DEK2X = RK2*RK2*EK2X DEDIFF = DEK1X-DEK2X DDF1 = A*DEDIFF + DEK2X DDF2 = B*DEDIFF UXX = 0.50E0*( Y21*(DDF1+Y21*DDF2) + Z1*(DDF1+Z1*DDF2) ) UYY = -(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2) UZZ = F2 PRHS = UXX + UYY + UZZ GO TO 9999 C 800 CONTINUE PRHS= 3.750E0*(SQRT(X*(Y*Z)**5)+SQRT(Y*(X*Z)**5)+SQRT(Z*(X*Y)**5)) GO TO 9999 C 1000 CONTINUE PRHS = -5.0E0*X*Y*Z GO TO 9999 C 1100 CONTINUE PRHS = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION BRHS (K,X,Y,Z) C C -------------------------------------- C RIGHT-HAND SIDE OF BOUNDARY CONDITIONS C -------------------------------------- C REAL X,Y,Z C COMMON / SELECT / IPROB C GO TO (100,200,300,400,100,100,700,800,900,1000,1100), IPROB C 100 CONTINUE BRHS = TRUE(X,Y,Z) GO TO 9999 C 200 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN BRHS = (1.0-X-X**2)*Y*(1.0-Y)*Z*(1.0-Z)*EXP(X+Y+Z) ELSE IF (K .EQ. 2) THEN BRHS = (1.0-Y-Y**2)*X*(1.0-X)*Z*(1.0-Z)*EXP(X+Y+Z) ELSE IF (K .EQ. 6) THEN BRHS = (1.0-Z-Z**2)*X*(1.0-X)*Y*(1.0-Y)*EXP(X+Y+Z) ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 300 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 4) .OR. (K .EQ. 5)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 400 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 3) .OR. (K .EQ. 6)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 700 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 4)) THEN S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X BRHS = -Y*F1 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 800 CONTINUE IF ((K .EQ. 2) .OR. (K .EQ. 3)) THEN BRHS = 0.0E0 ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 900 CONTINUE B = 4.0E0 IF ((K .EQ. 2) .OR. (K .EQ. 6)) THEN BRHS = TRUE(X,Y,Z) ELSE IF (K .EQ. 4) THEN BRHS = -B*( SIN(B*Y) + COS(B*(X-Y)) ) ELSE BRHS = -B*SIN(B*Z) ENDIF GO TO 9999 C 1000 CONTINUE IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN BRHS = Y*Z ELSE IF (K .EQ. 4) THEN BRHS = X*Z ELSE IF ((K .EQ. 5) .OR. (K .EQ. 6)) THEN BRHS = X*Y ELSE BRHS = TRUE(X,Y,Z) ENDIF GO TO 9999 C 1100 CONTINUE BRHS = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION TRUE(X,Y,Z) C C ------------- C TRUE SOLUTION C ------------- C REAL X,Y,Z C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB C TRUE = 0.0E0 GO TO 9999 C 100 CONTINUE TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z) GO TO 9999 C 200 CONTINUE TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z) GO TO 9999 C 300 CONTINUE TRUE = P(X)*P(Y)*P(Z) GO TO 9999 C 400 CONTINUE TRUE = ( Q(X,10.0E0) + Q(Y,20.0E0) + Q(Z,5.0E0) )/3.0E0 GO TO 9999 C 500 CONTINUE A = 0.750E0 TRUE = (X**A-X)*(Y**A-Y)*(Z**A-Z) GO TO 9999 C 600 CONTINUE B = 4.0E0 TRUE = COS(B*Y) + SIN(B*(X-Y)) + COS(B*Z) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y Z1 = 1.0E0 - Z TRUE = 0.50E0*( Y21*(F1 + Y21*F2) + Z1*(F1 + Z1*F2) ) GO TO 9999 C 800 CONTINUE TRUE = SQRT((X*Y*Z)**5) GO TO 9999 C 1000 CONTINUE TRUE = X*Y*Z GO TO 9999 C 1100 CONTINUE TRUE = 0.0E0 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 20 DZ = Z2 - Z1 P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ * + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3 RETURN 10 CONTINUE P = 1.0E0 RETURN 20 CONTINUE P = 0.0E0 RETURN END REAL FUNCTION D2P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 10 DZ = Z2 - Z1 C3 = -1.0E0/DZ**3 C4 = 3.0E0/DZ**4 C5 = -6.0E0/DZ**5 ZMZ1 = Z - Z1 ZMZ2 = Z - Z2 ZMZ12 = ZMZ1*ZMZ1 ZMZ22 = ZMZ2*ZMZ2 D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22 * + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1 RETURN 10 CONTINUE D2P = 0.0E0 RETURN END REAL FUNCTION Q (Z,A) Q = COSH(A*Z)/COSH(A) RETURN END SUBROUTINE TIMER (T) C C ------------------------------------------------ C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) C ------------------------------------------------ C REAL T T = SECOND() RETURN END C FISHPAK12 FROM PORTLIB 03/12/81 SUBROUTINE HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS, 1 BDYF,ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF, 2 MDIMF,F,PERTRB,IERROR,W) C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3.1 , OCTOBER 1980) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C * * * * * * * * * PURPOSE * * * * * * * * * * * * * * * * * * C C SUBROUTINE HW3CRT SOLVES THE STANDARD SEVEN-POINT FINITE C DIFFERENCE APPROXIMATION TO THE HELMHOLTZ EQUATION IN CARTESIAN C COORDINATES: C C (D/DX)(DU/DX) + (D/DY)(DU/DY) + (D/DZ)(DU/DZ) C C + LAMBDA*U = F(X,Y,Z) . C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C * * * * * * * * PARAMETER DESCRIPTION * * * * * * * * * * C C C * * * * * * ON INPUT * * * * * * C C XS,XF C THE RANGE OF X, I.E. XS .LE. X .LE. XF . C XS MUST BE LESS THAN XF. C C L C THE NUMBER OF PANELS INTO WHICH THE INTERVAL (XS,XF) IS C SUBDIVIDED. HENCE, THERE WILL BE L+1 GRID POINTS IN THE C X-DIRECTION GIVEN BY X(I) = XS+(I-1)DX FOR I=1,2,...,L+1, C WHERE DX = (XF-XS)/L IS THE PANEL WIDTH. L MUST BE AT C LEAST 5 . C C LBDCND C INDICATES THE TYPE OF BOUNDARY CONDITIONS AT X = XS AND X = XF. C C = 0 IF THE SOLUTION IS PERIODIC IN X, I.E. C U(L+I,J,K) = U(I,J,K). C = 1 IF THE SOLUTION IS SPECIFIED AT X = XS AND X = XF. C = 2 IF THE SOLUTION IS SPECIFIED AT X = XS AND THE DERIVATIVE C OF THE SOLUTION WITH RESPECT TO X IS SPECIFIED AT X = XF. C = 3 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS C SPECIFIED AT X = XS AND X = XF. C = 4 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS C SPECIFIED AT X = XS AND THE SOLUTION IS SPECIFIED AT X=XF. C C BDXS C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XS. C WHEN LBDCND = 3 OR 4, C C BDXS(J,K) = (D/DX)U(XS,Y(J),Z(K)), J=1,2,...,M+1, C K=1,2,...,N+1. C C WHEN LBDCND HAS ANY OTHER VALUE, BDXS IS A DUMMY VARIABLE. C BDXS MUST BE DIMENSIONED AT LEAST (M+1)*(N+1). C C BDXF C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XF. C WHEN LBDCND = 2 OR 3, C C BDXF(J,K) = (D/DX)U(XF,Y(J),Z(K)), J=1,2,...,M+1, C K=1,2,...,N+1. C C WHEN LBDCND HAS ANY OTHER VALUE, BDXF IS A DUMMY VARIABLE. C BDXF MUST BE DIMENSIONED AT LEAST (M+1)*(N+1). C C YS,YF C THE RANGE OF Y, I.E. YS .LE. Y .LE. YF. C YS MUST BE LESS THAN YF. C C M C THE NUMBER OF PANELS INTO WHICH THE INTERVAL (YS,YF) IS C SUBDIVIDED. HENCE, THERE WILL BE M+1 GRID POINTS IN THE C Y-DIRECTION GIVEN BY Y(J) = YS+(J-1)DY FOR J=1,2,...,M+1, C WHERE DY = (YF-YS)/M IS THE PANEL WIDTH. M MUST BE AT C LEAST 5 . C C MBDCND C INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Y = YS AND Y = YF. C C = 0 IF THE SOLUTION IS PERIODIC IN Y, I.E. C U(I,M+J,K) = U(I,J,K). C = 1 IF THE SOLUTION IS SPECIFIED AT Y = YS AND Y = YF. C = 2 IF THE SOLUTION IS SPECIFIED AT Y = YS AND THE DERIVATIVE C OF THE SOLUTION WITH RESPECT TO Y IS SPECIFIED AT Y = YF. C = 3 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS C SPECIFIED AT Y = YS AND Y = YF. C = 4 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS C SPECIFIED AT Y = YS AND THE SOLUTION IS SPECIFIED AT Y=YF. C C BDYS C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YS. C WHEN MBDCND = 3 OR 4, C C BDYS(I,K) = (D/DY)U(X(I),YS,Z(K)), I=1,2,...,L+1, C K=1,2,...,N+1. C C WHEN MBDCND HAS ANY OTHER VALUE, BDYS IS A DUMMY VARIABLE. C BDYS MUST BE DIMENSIONED AT LEAST (L+1)*(N+1). C C BDYF C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YF. C WHEN MBDCND = 2 OR 3, C C BDYF(I,K) = (D/DY)U(X(I),YF,Z(K)), I=1,2,...,L+1, C K=1,2,...,N+1. C C WHEN MBDCND HAS ANY OTHER VALUE, BDYF IS A DUMMY VARIABLE. C BDYF MUST BE DIMENSIONED AT LEAST (L+1)*(N+1). C C ZS,ZF C THE RANGE OF Z, I.E. ZS .LE. Z .LE. ZF. C ZS MUST BE LESS THAN ZF. C C N C THE NUMBER OF PANELS INTO WHICH THE INTERVAL (ZS,ZF) IS C SUBDIVIDED. HENCE, THERE WILL BE N+1 GRID POINTS IN THE C Z-DIRECTION GIVEN BY Z(K) = ZS+(K-1)DZ FOR K=1,2,...,N+1, C WHERE DZ = (ZF-ZS)/N IS THE PANEL WIDTH. N MUST BE AT LEAST 5. C C NBDCND C INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Z = ZS AND Z = ZF. C C = 0 IF THE SOLUTION IS PERIODIC IN Z, I.E. C U(I,J,N+K) = U(I,J,K). C = 1 IF THE SOLUTION IS SPECIFIED AT Z = ZS AND Z = ZF. C = 2 IF THE SOLUTION IS SPECIFIED AT Z = ZS AND THE DERIVATIVE C OF THE SOLUTION WITH RESPECT TO Z IS SPECIFIED AT Z = ZF. C = 3 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS C SPECIFIED AT Z = ZS AND Z = ZF. C = 4 IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS C SPECIFIED AT Z = ZS AND THE SOLUTION IS SPECIFIED AT Z=ZF. C C BDZS C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZS. C WHEN NBDCND = 3 OR 4, C C BDZS(I,J) = (D/DZ)U(X(I),Y(J),ZS), I=1,2,...,L+1, C J=1,2,...,M+1. C C WHEN NBDCND HAS ANY OTHER VALUE, BDZS IS A DUMMY VARIABLE. C BDZS MUST BE DIMENSIONED AT LEAST (L+1)*(M+1). C C BDZF C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZF. C WHEN NBDCND = 2 OR 3, C C BDZF(I,J) = (D/DZ)U(X(I),Y(J),ZF), I=1,2,...,L+1, C J=1,2,...,M+1. C C WHEN NBDCND HAS ANY OTHER VALUE, BDZF IS A DUMMY VARIABLE. C BDZF MUST BE DIMENSIONED AT LEAST (L+1)*(M+1). C C ELMBDA C THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION. IF C LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST. HOWEVER, HW3CRT WILL C ATTEMPT TO FIND A SOLUTION. C C F C A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE C RIGHT SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF C ANY). FOR I=2,3,...,L, J=2,3,...,M, AND K=2,3,...,N C C F(I,J,K) = F(X(I),Y(J),Z(K)). C C ON THE BOUNDARIES F IS DEFINED BY C C LBDCND F(1,J,K) F(L+1,J,K) C ------ --------------- --------------- C C 0 F(XS,Y(J),Z(K)) F(XS,Y(J),Z(K)) C 1 U(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) C 2 U(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) J=1,2,...,M+1 C 3 F(XS,Y(J),Z(K)) F(XF,Y(J),Z(K)) K=1,2,...,N+1 C 4 F(XS,Y(J),Z(K)) U(XF,Y(J),Z(K)) C C MBDCND F(I,1,K) F(I,M+1,K) C ------ --------------- --------------- C C 0 F(X(I),YS,Z(K)) F(X(I),YS,Z(K)) C 1 U(X(I),YS,Z(K)) U(X(I),YF,Z(K)) C 2 U(X(I),YS,Z(K)) F(X(I),YF,Z(K)) I=1,2,...,L+1 C 3 F(X(I),YS,Z(K)) F(X(I),YF,Z(K)) K=1,2,...,N+1 C 4 F(X(I),YS,Z(K)) U(X(I),YF,Z(K)) C C NBDCND F(I,J,1) F(I,J,N+1) C ------ --------------- --------------- C C 0 F(X(I),Y(J),ZS) F(X(I),Y(J),ZS) C 1 U(X(I),Y(J),ZS) U(X(I),Y(J),ZF) C 2 U(X(I),Y(J),ZS) F(X(I),Y(J),ZF) I=1,2,...,L+1 C 3 F(X(I),Y(J),ZS) F(X(I),Y(J),ZF) J=1,2,...,M+1 C 4 F(X(I),Y(J),ZS) U(X(I),Y(J),ZF) C C F MUST BE DIMENSIONED AT LEAST (L+1)*(M+1)*(N+1). C C NOTE: C C IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F C ON A BOUNDARY, THEN THE SOLUTION MUST BE SPECIFIED. C C LDIMF C THE ROW (OR FIRST) DIMENSION OF THE ARRAYS F,BDYS,BDYF,BDZS, C AND BDZF AS IT APPEARS IN THE PROGRAM CALLING HW3CRT. THIS C PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION OF THESE C ARRAYS. LDIMF MUST BE AT LEAST L+1. C C MDIMF C THE COLUMN (OR SECOND) DIMENSION OF THE ARRAY F AND THE ROW (OR C FIRST) DIMENSION OF THE ARRAYS BDXS AND BDXF AS IT APPEARS IN C THE PROGRAM CALLING HW3CRT. THIS PARAMETER IS USED TO SPECIFY C THE VARIABLE DIMENSION OF THESE ARRAYS. C MDIMF MUST BE AT LEAST M+1. C C W C A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR C WORK SPACE. THE LENGTH OF W MUST BE AT LEAST 30 + L + M + 5*N C + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2)) C C C * * * * * * ON OUTPUT * * * * * * C C F C CONTAINS THE SOLUTION U(I,J,K) OF THE FINITE DIFFERENCE C APPROXIMATION FOR THE GRID POINT (X(I),Y(J),Z(K)) FOR C I=1,2,...,L+1, J=1,2,...,M+1, AND K=1,2,...,N+1. C C PERTRB C IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS C IS SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION C MAY NOT EXIST. PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED C FROM F, WHICH ENSURES THAT A SOLUTION EXISTS. PWSCRT THEN C COMPUTES THIS SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO C THE ORIGINAL APPROXIMATION. THIS SOLUTION IS NOT UNIQUE AND IS C UNNORMALIZED. THE VALUE OF PERTRB SHOULD BE SMALL COMPARED TO C THE RIGHT SIDE F. OTHERWISE, A SOLUTION IS OBTAINED TO AN C ESSENTIALLY DIFFERENT PROBLEM. THIS COMPARISON SHOULD ALWAYS C BE MADE TO INSURE THAT A MEANINGFUL SOLUTION HAS BEEN OBTAINED. C C IERROR C AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS. EXCEPT C FOR NUMBERS 0 AND 12, A SOLUTION IS NOT ATTEMPTED. C C = 0 NO ERROR C = 1 XS .GE. XF C = 2 L .LT. 5 C = 3 LBDCND .LT. 0 .OR. LBDCND .GT. 4 C = 4 YS .GE. YF C = 5 M .LT. 5 C = 6 MBDCND .LT. 0 .OR. MBDCND .GT. 4 C = 7 ZS .GE. ZF C = 8 N .LT. 5 C = 9 NBDCND .LT. 0 .OR. NBDCND .GT. 4 C = 10 LDIMF .LT. L+1 C = 11 MDIMF .LT. M+1 C = 12 LAMBDA .GT. 0 C C SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY INCORRECT C CALL TO HW3CRT, THE USER SHOULD TEST IERROR AFTER THE CALL. C C C * * * * * * * PROGRAM SPECIFICATIONS * * * * * * * * * * * * C C DIMENSION OF BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1), C ARGUMENTS BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1), C F(LDIMF,MDIMF,N+1),W(SEE ARGUMENT LIST) C C LATEST DECEMBER 1, 1978 C REVISION C C SUBPROGRAMS HW3CRT,POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1, C REQUIRED RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF, C COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI, C CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB, C CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF, C PIMACH C C SPECIAL NONE C CONDITIONS C C COMMON VALUE C BLOCKS C C I/O NONE C C PRECISION SINGLE C C SPECIALIST ROLAND SWEET C C LANGUAGE FORTRAN C C HISTORY WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977 C C ALGORITHM THIS SUBROUTINE DEFINES THE FINITE DIFFERENCE C EQUATIONS, INCORPORATES BOUNDARY DATA, AND C ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS AND C THEN CALLS POIS3D TO SOLVE THE SYSTEM. C C SPACE 7862(DECIMAL) = 17300(OCTAL) LOCATIONS ON THE C REQUIRED NCAR CONTROL DATA 7600 C C TIMING AND THE EXECUTION TIME T ON THE NCAR CONTROL DATA C ACCURACY 7600 FOR SUBROUTINE HW3CRT IS ROUGHLY PROPORTIONAL C TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON C INPUT PARAMETERS LBDCND AND MBDCND. SOME TYPICAL C VALUES ARE LISTED IN THE TABLE BELOW. C THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS C OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR L,M AN C N AS LARGE AS 32. MORE DETAILED INFORMATION ABOUT C ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR C SUBROUTINE POIS3D WHICH IS THE ROUTINE THAT ACTUALL C SOLVES THE FINITE DIFFERENCE EQUATIONS. C C C L(=M=N) LBDCND(=MBDCND=NBDCND) T(MSECS) C ------- ---------------------- -------- C C 16 0 300 C 16 1 302 C 16 3 348 C 32 0 1925 C 32 1 1929 C 32 3 2109 C C PORTABILITY AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN. C THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN C FUNCTION PIMACH. C C REQUIRED COS,SIN,ATAN C RESIDENT C ROUTINES C C REFERENCE NONE C C REQUIRED COS,SIN,ATAN C RESIDENT C ROUTINES C C REFERENCE NONE C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DIMENSION BDXS(MDIMF,1) ,BDXF(MDIMF,1) , 1 BDYS(LDIMF,1) ,BDYF(LDIMF,1) , 2 BDZS(LDIMF,1) ,BDZF(LDIMF,1) , 3 F(LDIMF,MDIMF,1) ,W(1) C C CHECK FOR INVALID INPUT. C IERROR = 0 IF (XF .LE. XS) IERROR = 1 IF (L .LT. 5) IERROR = 2 IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3 IF (YF .LE. YS) IERROR = 4 IF (M .LT. 5) IERROR = 5 IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6 IF (ZF .LE. ZS) IERROR = 7 IF (N .LT. 5) IERROR = 8 IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9 IF (LDIMF .LT. L+1) IERROR = 10 IF (MDIMF .LT. M+1) IERROR = 11 IF (IERROR .NE. 0) GO TO 188 DY = (YF-YS)/FLOAT(M) TWBYDY = 2./DY C2 = 1./(DY**2) MSTART = 1 MSTOP = M MP1 = M+1 MP = MBDCND+1 GO TO (104,101,101,102,102),MP 101 MSTART = 2 102 GO TO (104,104,103,103,104),MP 103 MSTOP = MP1 104 MUNK = MSTOP-MSTART+1 DZ = (ZF-ZS)/FLOAT(N) TWBYDZ = 2./DZ NP = NBDCND+1 C3 = 1./(DZ**2) NP1 = N+1 NSTART = 1 NSTOP = N GO TO (108,105,105,106,106),NP 105 NSTART = 2 106 GO TO (108,108,107,107,108),NP 107 NSTOP = NP1 108 NUNK = NSTOP-NSTART+1 LP1 = L+1 DX = (XF-XS)/FLOAT(L) C1 = 1./(DX**2) TWBYDX = 2./DX LP = LBDCND+1 LSTART = 1 LSTOP = L C C ENTER BOUNDARY DATA FOR X-BOUNDARIES. C GO TO (122,109,109,112,112),LP 109 LSTART = 2 DO 111 J=MSTART,MSTOP DO 110 K=NSTART,NSTOP F(2,J,K) = F(2,J,K)-C1*F(1,J,K) 110 CONTINUE 111 CONTINUE GO TO 115 112 DO 114 J=MSTART,MSTOP DO 113 K=NSTART,NSTOP F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K) 113 CONTINUE 114 CONTINUE 115 GO TO (122,116,119,119,116),LP 116 DO 118 J=MSTART,MSTOP DO 117 K=NSTART,NSTOP F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K) 117 CONTINUE 118 CONTINUE GO TO 122 119 LSTOP = LP1 DO 121 J=MSTART,MSTOP DO 120 K=NSTART,NSTOP F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K) 120 CONTINUE 121 CONTINUE 122 LUNK = LSTOP-LSTART+1 C C ENTER BOUNDARY DATA FOR Y-BOUNDARIES. C GO TO (136,123,123,126,126),MP 123 DO 125 I=LSTART,LSTOP DO 124 K=NSTART,NSTOP F(I,2,K) = F(I,2,K)-C2*F(I,1,K) 124 CONTINUE 125 CONTINUE GO TO 129 126 DO 128 I=LSTART,LSTOP DO 127 K=NSTART,NSTOP F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K) 127 CONTINUE 128 CONTINUE 129 GO TO (136,130,133,133,130),MP 130 DO 132 I=LSTART,LSTOP DO 131 K=NSTART,NSTOP F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K) 131 CONTINUE 132 CONTINUE GO TO 136 133 DO 135 I=LSTART,LSTOP DO 134 K=NSTART,NSTOP F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K) 134 CONTINUE 135 CONTINUE 136 CONTINUE C C ENTER BOUNDARY DATA FOR Z-BOUNDARIES. C GO TO (150,137,137,140,140),NP 137 DO 139 I=LSTART,LSTOP DO 138 J=MSTART,MSTOP F(I,J,2) = F(I,J,2)-C3*F(I,J,1) 138 CONTINUE 139 CONTINUE GO TO 143 140 DO 142 I=LSTART,LSTOP DO 141 J=MSTART,MSTOP F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J) 141 CONTINUE 142 CONTINUE 143 GO TO (150,144,147,147,144),NP 144 DO 146 I=LSTART,LSTOP DO 145 J=MSTART,MSTOP F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1) 145 CONTINUE 146 CONTINUE GO TO 150 147 DO 149 I=LSTART,LSTOP DO 148 J=MSTART,MSTOP F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J) 148 CONTINUE 149 CONTINUE C C DEFINE A,B,C COEFFICIENTS IN W-ARRAY. C 150 CONTINUE IWB = NUNK+1 IWC = IWB+NUNK IWW = IWC+NUNK DO 151 K=1,NUNK I = IWC+K-1 W(K) = C3 W(I) = C3 I = IWB+K-1 W(I) = -2.*C3+ELMBDA 151 CONTINUE GO TO (155,155,153,152,152),NP 152 W(IWC) = 2.*C3 153 GO TO (155,155,154,154,155),NP 154 W(IWB-1) = 2.*C3 155 CONTINUE PERTRB = 0. C C FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST. C GO TO (156,172,172,156,172),LP 156 GO TO (157,172,172,157,172),MP 157 GO TO (158,172,172,158,172),NP 158 IF (ELMBDA) 172,160,159 159 IERROR = 12 GO TO 172 160 CONTINUE MSTPM1 = MSTOP-1 LSTPM1 = LSTOP-1 NSTPM1 = NSTOP-1 XLP = (2+LP)/3 YLP = (2+MP)/3 ZLP = (2+NP)/3 S1 = 0. DO 164 K=2,NSTPM1 DO 162 J=2,MSTPM1 DO 161 I=2,LSTPM1 S1 = S1+F(I,J,K) 161 CONTINUE S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP 162 CONTINUE S2 = 0. DO 163 I=2,LSTPM1 S2 = S2+F(I,1,K)+F(I,MSTOP,K) 163 CONTINUE S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/ 1 XLP)/YLP S1 = S1+S2 164 CONTINUE S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+ 1 F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+ 2 F(LSTOP,MSTOP,NSTOP))/(XLP*YLP) DO 166 J=2,MSTPM1 DO 165 I=2,LSTPM1 S = S+F(I,J,1)+F(I,J,NSTOP) 165 CONTINUE 166 CONTINUE S2 = 0. DO 167 I=2,LSTPM1 S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP) 167 CONTINUE S = S2/YLP+S S2 = 0. DO 168 J=2,MSTPM1 S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP) 168 CONTINUE S = S2/XLP+S PERTRB = (S/ZLP+S1)/((FLOAT(LUNK+1)-XLP)*(FLOAT(MUNK+1)-YLP)* 1 (FLOAT(NUNK+1)-ZLP)) DO 171 I=1,LUNK DO 170 J=1,MUNK DO 169 K=1,NUNK F(I,J,K) = F(I,J,K)-PERTRB 169 CONTINUE 170 CONTINUE 171 CONTINUE 172 CONTINUE NPEROD = 0 IF (NBDCND .EQ. 0) GO TO 173 NPEROD = 1 W(1) = 0. W(IWW-1) = 0. 173 CONTINUE CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB), 1 W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW)) C C FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS. C IF (LP .NE. 1) GO TO 180 IF (MP .NE. 1) GO TO 175 DO 174 K=NSTART,NSTOP F(1,MP1,K) = F(1,1,K) 174 CONTINUE MSTOP = MP1 175 IF (NP .NE. 1) GO TO 177 DO 176 J=MSTART,MSTOP F(1,J,NP1) = F(1,J,1) 176 CONTINUE NSTOP = NP1 177 DO 179 J=MSTART,MSTOP DO 178 K=NSTART,NSTOP F(LP1,J,K) = F(1,J,K) 178 CONTINUE 179 CONTINUE 180 CONTINUE IF (MP .NE. 1) GO TO 185 IF (NP .NE. 1) GO TO 182 DO 181 I=LSTART,LSTOP F(I,1,NP1) = F(I,1,1) 181 CONTINUE NSTOP = NP1 182 DO 184 I=LSTART,LSTOP DO 183 K=NSTART,NSTOP F(I,MP1,K) = F(I,1,K) 183 CONTINUE 184 CONTINUE 185 CONTINUE IF (NP .NE. 1) GO TO 188 DO 187 I=LSTART,LSTOP DO 186 J=MSTART,MSTOP F(I,J,NP1) = F(I,J,1) 186 CONTINUE 187 CONTINUE 188 CONTINUE RETURN END C FISHPAK18 FROM PORTLIB 03/12/81 SUBROUTINE POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF, 1 MDIMF,F,IERROR,W) C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3.1 , OCTOBER 1980) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C * * * * * * * * * PURPOSE * * * * * * * * * * * * * * * * * * C C SUBROUTINE POIS3D SOLVES THE LINEAR SYSTEM OF EQUATIONS C C C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K)) C + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K)) C + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K) C C FOR I=1,2,...,L , J=1,2,...,M , AND K=1,2,...,N . C C THE INDICES K-1 AND K+1 ARE EVALUATED MODULO N, I.E. C X(I,J,0) = X(I,J,N) AND X(I,J,N+1) = X(I,J,1). THE UNKNOWNS C X(0,J,K), X(L+1,J,K), X(I,0,K), AND X(I,M+1,K) ARE ASSUMED TO TAKE C ON CERTAIN PRESCRIBED VALUES DESCRIBED BELOW. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C * * * * * * * * PARAMETER DESCRIPTION * * * * * * * * * * C C C * * * * * * ON INPUT * * * * * * C C LPEROD INDICATES THE VALUES THAT X(0,J,K) AND X(L+1,J,K) ARE C ASSUMED TO HAVE. C C = 0 IF X(0,J,K) = X(L,J,K) AND X(L+1,J,K) = X(1,J,K). C = 1 IF X(0,J,K) = X(L+1,J,K) = 0. C = 2 IF X(0,J,K) = 0 AND X(L+1,J,K) = X(L-1,J,K). C = 3 IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = X(L-1,J,K). C = 4 IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = 0. C C L THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. L MUST BE AT C LEAST 3. C C C1 THE REAL CONSTANT THAT APPEARS IN THE ABOVE EQUATION. C C MPEROD INDICATES THE VALUES THAT X(I,0,K) AND X(I,M+1,K) ARE C ASSUMED TO HAVE. C C = 0 IF X(I,0,K) = X(I,M,K) AND X(I,M+1,K) = X(I,1,K). C = 1 IF X(I,0,K) = X(I,M+1,K) = 0. C = 2 IF X(I,0,K) = 0 AND X(I,M+1,K) = X(I,M-1,K). C = 3 IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = X(I,M-1,K). C = 4 IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = 0. C C M THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. M MUST BE AT C LEAST 3. C C C2 THE REAL CONSTANT WHICH APPEARS IN THE ABOVE EQUATION. C C NPEROD = 0 IF A(1) AND C(N) ARE NOT ZERO. C = 1 IF A(1) = C(N) = 0. C C N THE NUMBER OF UNKNOWNS IN THE K-DIRECTION. N MUST BE AT C LEAST 3. C C C A,B,C ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE C COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE. C C IF NPEROD = 0 THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE C INDEX K, BUT MUST BE CONSTANT. SPECIFICALLY,THE C SUBROUTINE CHECKS THE FOLLOWING CONDITION C C A(K) = C(1) C C(K) = C(1) C B(K) = B(1) C C FOR K=1,2,...,N. C C LDIMF THE ROW (OR FIRST) DIMENSION OF THE THREE-DIMENSIONAL C ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D. C THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION C OF F. LDIMF MUST BE AT LEAST L. C C MDIMF THE COLUMN (OR SECOND) DIMENSION OF THE THREE-DIMENSIONAL C ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D. C THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION C OF F. MDIMF MUST BE AT LEAST M. C C F A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF C THE RIGHT SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN C ABOVE. F MUST BE DIMENSIONED AT LEAST L X M X N. C C W A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE C USER FOR WORK SPACE. THE LENGTH OF W MUST BE AT LEAST C 30 + L + M + 2*N + MAX(L,M,N) + C 7*(INT((L+1)/2) + INT((M+1)/2)). C C C * * * * * * ON OUTPUT * * * * * * C C F CONTAINS THE SOLUTION X. C C IERROR AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS. C EXCEPT FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED. C = 0 NO ERROR C = 1 IF LPEROD .LT. 0 OR .GT. 4 C = 2 IF L .LT. 3 C = 3 IF MPEROD .LT. 0 OR .GT. 4 C = 4 IF M .LT. 3 C = 5 IF NPEROD .LT. 0 OR .GT. 1 C = 6 IF N .LT. 3 C = 7 IF LDIMF .LT. L C = 8 IF MDIMF .LT. M C = 9 IF A(K) .NE. C(1) OR C(K) .NE. C(1) OR B(I) .NE.B(1) C FOR SOME K=1,2,...,N. C = 10 IF NPEROD = 1 AND A(1) .NE. 0 OR C(N) .NE. 0 C C SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY C INCORRECT CALL TO POIS3D, THE USER SHOULD TEST IERROR C AFTER THE CALL. C C C * * * * * * * PROGRAM SPECIFICATIONS * * * * * * * * * * * * C C DIMENSION OF A(N),B(N),C(N),F(LDIMF,MDIMF,N), C ARGUMENTS W(SEE ARGUMENT LIST) C C LATEST DECEMBER 1, 1978 C REVISION C C SUBPROGRAMS POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,RFFTB, C REQUIRED RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1 C COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1, C CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF, C CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH, C C SPECIAL NONE C CONDITIONS C C COMMON VALUE C BLOCKS C C I/O NONE C C PRECISION SINGLE C C SPECIALIST ROLAND SWEET C C LANGUAGE FORTRAN C C HISTORY WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977 C C ALGORITHM THIS SUBROUTINE SOLVES THREE-DIMENSIONAL BLOCK C TRIDIAGONAL LINEAR SYSTEMS ARISING FROM FINITE C DIFFERENCE APPROXIMATIONS TO THREE-DIMENSIONAL C POISSON EQUATIONS USING THE FOURIER TRANSFORM C PACKAGE SCLRFFTPAK WRITTEN BY PAUL SWARZTRAUBER. C C SPACE 6561(DECIMAL) = 14641(OCTAL) LOCATIONS ON THE C REQUIRED NCAR CONTROL DATA 7600 C C TIMING AND THE EXECUTION TIME T ON THE NCAR CONTROL DATA C ACCURACY 7600 FOR SUBROUTINE POIS3D IS ROUGHLY PROPORTIONAL C TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON C INPUT PARAMETERS LPEROD AND MPEROD. SOME TYPICAL C VALUES ARE LISTED IN THE TABLE BELOW WHEN NPEROD=0. C TO MEASURE THE ACCURACY OF THE ALGORITHM A C UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE C A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE C "PURPOSE" WITH C C A(K) = C(K) = -0.5*B(K) = 1, K=1,2,...,N C C AND, WHEN NPEROD = 1 C C A(1) = C(N) = 0 C A(N) = C(1) = 2. C C THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS- C TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS C COMPUTED. USING THIS ARRAY Y SUBROUTINE POIS WAS C CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z. THEN C THE RELATIVE ERROR, DEFINED AS C C E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K))) C C WHERE THE TWO MAXIMA ARE TAKEN OVER I=1,2,...,L, C J=1,2,...,M AND K=1,2,...,N, WAS COMPUTED. THE C VALUE OF E IS GIVEN IN THE TABLE BELOW FOR SOME C TYPICAL VALUES OF L,M AND N. C C C L(=M=N) LPEROD MPEROD T(MSECS) E C ------ ------ ------ -------- ------ C C 16 0 0 272 1.E-13 C 15 1 1 287 4.E-13 C 17 3 3 338 2.E-13 C 32 0 0 1755 2.E-13 C 31 1 1 1894 2.E-12 C 33 3 3 2042 7.E-13 C C C PORTABILITY AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN. C THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN C FUNCTION PIMACH. C C REQUIRED COS,SIN,ATAN C RESIDENT C ROUTINES C C REFERENCE NONE C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C DIMENSION A(1) ,B(1) ,C(1) , 1 F(LDIMF,MDIMF,1) ,W(1) ,SAVE(6) LP = LPEROD+1 MP = MPEROD+1 NP = NPEROD+1 C C CHECK FOR INVALID INPUT. C IERROR = 0 IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1 IF (L .LT. 3) IERROR = 2 IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3 IF (M .LT. 3) IERROR = 4 IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5 IF (N .LT. 3) IERROR = 6 IF (LDIMF .LT. L) IERROR = 7 IF (MDIMF .LT. M) IERROR = 8 IF (NP .NE. 1) GO TO 103 DO 101 K=1,N IF (A(K) .NE. C(1)) GO TO 102 IF (C(K) .NE. C(1)) GO TO 102 IF (B(K) .NE. B(1)) GO TO 102 101 CONTINUE GO TO 104 102 IERROR = 9 103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10 104 IF (IERROR .NE. 0) GO TO 122 IWYRT = L+1 IWT = IWYRT+M IWD = IWT+MAX0(L,M,N)+1 IWBB = IWD+N IWX = IWBB+N IWY = IWX+7*((L+1)/2)+15 GO TO (105,114),NP C C REORDER UNKNOWNS WHEN NPEROD = 0. C 105 NH = (N+1)/2 NHM1 = NH-1 NODD = 1 IF (2*NH .EQ. N) NODD = 2 DO 111 I=1,L DO 110 J=1,M DO 106 K=1,NHM1 NHPK = NH+K NHMK = NH-K W(K) = F(I,J,NHMK)-F(I,J,NHPK) W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK) 106 CONTINUE W(NH) = 2.*F(I,J,NH) GO TO (108,107),NODD 107 W(N) = 2.*F(I,J,N) 108 DO 109 K=1,N F(I,J,K) = W(K) 109 CONTINUE 110 CONTINUE 111 CONTINUE SAVE(1) = C(NHM1) SAVE(2) = A(NH) SAVE(3) = C(NH) SAVE(4) = B(NHM1) SAVE(5) = B(N) SAVE(6) = A(N) C(NHM1) = 0. A(NH) = 0. C(NH) = 2.*C(NH) GO TO (112,113),NODD 112 B(NHM1) = B(NHM1)-A(NH-1) B(N) = B(N)+A(N) GO TO 114 113 A(N) = C(NH) 114 CONTINUE CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT), 1 W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB)) GO TO (115,122),NP 115 DO 121 I=1,L DO 120 J=1,M DO 116 K=1,NHM1 NHMK = NH-K NHPK = NH+K W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K)) W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K)) 116 CONTINUE W(NH) = .5*F(I,J,NH) GO TO (118,117),NODD 117 W(N) = .5*F(I,J,N) 118 DO 119 K=1,N F(I,J,K) = W(K) 119 CONTINUE 120 CONTINUE 121 CONTINUE C(NHM1) = SAVE(1) A(NH) = SAVE(2) C(NH) = SAVE(3) B(NHM1) = SAVE(4) B(N) = SAVE(5) A(N) = SAVE(6) 122 CONTINUE RETURN END SUBROUTINE POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,XRT,YRT,T,D, 1 WX,WY,C1,C2,BB) DIMENSION A(1) ,B(1) ,C(1) , 1 F(LDIMF,MDIMF,1) ,XRT(1) ,YRT(1) , 2 T(1) ,D(1) ,WX(1) ,WY(1) , 3 BB(1) PI = PIMACH(DUM) LR = L MR = M NR = N C C GENERATE TRANSFORM ROOTS C LRDEL = ((LP-1)*(LP-3)*(LP-5))/3 SCALX = LR+LRDEL DX = PI/(2.*SCALX) GO TO (108,103,101,102,101),LP 101 DI = 0.5 SCALX = 2.*SCALX GO TO 104 102 DI = 1.0 GO TO 104 103 DI = 0.0 104 DO 105 I=1,LR XRT(I) = -4.*C1*(SIN((FLOAT(I)-DI)*DX))**2 105 CONTINUE SCALX = 2.*SCALX GO TO (112,106,110,107,111),LP 106 CALL SINTI (LR,WX) GO TO 112 107 CALL COSTI (LR,WX) GO TO 112 108 XRT(1) = 0. XRT(LR) = -4.*C1 DO 109 I=3,LR,2 XRT(I-1) = -4.*C1*(SIN(FLOAT((I-1))*DX))**2 XRT(I) = XRT(I-1) 109 CONTINUE CALL RFFTI (LR,WX) GO TO 112 110 CALL SINQI (LR,WX) GO TO 112 111 CALL COSQI (LR,WX) 112 CONTINUE MRDEL = ((MP-1)*(MP-3)*(MP-5))/3 SCALY = MR+MRDEL DY = PI/(2.*SCALY) GO TO (120,115,113,114,113),MP 113 DJ = 0.5 SCALY = 2.*SCALY GO TO 116 114 DJ = 1.0 GO TO 116 115 DJ = 0.0 116 DO 117 J=1,MR YRT(J) = -4.*C2*(SIN((FLOAT(J)-DJ)*DY))**2 117 CONTINUE SCALY = 2.*SCALY GO TO (124,118,122,119,123),MP 118 CALL SINTI (MR,WY) GO TO 124 119 CALL COSTI (MR,WY) GO TO 124 120 YRT(1) = 0. YRT(MR) = -4.*C2 DO 121 J=3,MR,2 YRT(J-1) = -4.*C2*(SIN(FLOAT((J-1))*DY))**2 YRT(J) = YRT(J-1) 121 CONTINUE CALL RFFTI (MR,WY) GO TO 124 122 CALL SINQI (MR,WY) GO TO 124 123 CALL COSQI (MR,WY) 124 CONTINUE IFWRD = 1 IS = 1 125 CONTINUE C C TRANSFORM X C DO 141 J=1,MR DO 140 K=1,NR DO 126 I=1,LR T(I) = F(I,J,K) 126 CONTINUE GO TO (127,130,131,134,135),LP 127 GO TO (128,129),IFWRD 128 CALL RFFTF (LR,T,WX) GO TO 138 129 CALL RFFTB (LR,T,WX) GO TO 138 130 CALL SINT (LR,T,WX) GO TO 138 131 GO TO (132,133),IFWRD 132 CALL SINQF (LR,T,WX) GO TO 138 133 CALL SINQB (LR,T,WX) GO TO 138 134 CALL COST (LR,T,WX) GO TO 138 135 GO TO (136,137),IFWRD 136 CALL COSQF (LR,T,WX) GO TO 138 137 CALL COSQB (LR,T,WX) 138 CONTINUE DO 139 I=1,LR F(I,J,K) = T(I) 139 CONTINUE 140 CONTINUE 141 CONTINUE GO TO (142,164),IFWRD C C TRANSFORM Y C 142 CONTINUE DO 158 I=1,LR DO 157 K=1,NR DO 143 J=1,MR T(J) = F(I,J,K) 143 CONTINUE GO TO (144,147,148,151,152),MP 144 GO TO (145,146),IFWRD 145 CALL RFFTF (MR,T,WY) GO TO 155 146 CALL RFFTB (MR,T,WY) GO TO 155 147 CALL SINT (MR,T,WY) GO TO 155 148 GO TO (149,150),IFWRD 149 CALL SINQF (MR,T,WY) GO TO 155 150 CALL SINQB (MR,T,WY) GO TO 155 151 CALL COST (MR,T,WY) GO TO 155 152 GO TO (153,154),IFWRD 153 CALL COSQF (MR,T,WY) GO TO 155 154 CALL COSQB (MR,T,WY) 155 CONTINUE DO 156 J=1,MR F(I,J,K) = T(J) 156 CONTINUE 157 CONTINUE 158 CONTINUE GO TO (159,125),IFWRD 159 CONTINUE C C SOLVE TRIDIAGONAL SYSTEMS IN Z C DO 163 I=1,LR DO 162 J=1,MR DO 160 K=1,NR BB(K) = B(K)+XRT(I)+YRT(J) T(K) = F(I,J,K) 160 CONTINUE CALL TRID (NR,A,BB,C,T,D) DO 161 K=1,NR F(I,J,K) = T(K) 161 CONTINUE 162 CONTINUE 163 CONTINUE IFWRD = 2 IS = -1 GO TO 142 164 CONTINUE DO 167 I=1,LR DO 166 J=1,MR DO 165 K=1,NR F(I,J,K) = F(I,J,K)/(SCALX*SCALY) 165 CONTINUE 166 CONTINUE 167 CONTINUE RETURN END FUNCTION PIMACH (DUM) C C THIS SUBPROGRAM SUPPLIES THE VALUE OF THE CONSTANT PI CORRECT TO C MACHINE PRECISION WHERE C C PI=3.1415926535897932384626433832795028841971693993751058209749446 C PIMACH = 3.14159265358979 RETURN END SUBROUTINE TRID(MR,A,B,C,Y,D) C***BEGIN PROLOGUE TRID C***REFER TO POIS3D C***ROUTINES CALLED (NONE) C***END PROLOGUE TRID DIMENSION A(1) ,B(1) ,C(1) ,Y(1) , 1 D(1) C***FIRST EXECUTABLE STATEMENT TRID M = MR MM1 = M-1 Z = 1./B(1) D(1) = C(1)*Z Y(1) = Y(1)*Z DO 101 I=2,MM1 Z = 1./(B(I)-A(I)*D(I-1)) D(I) = C(I)*Z Y(I) = (Y(I)-A(I)*Y(I-1))*Z 101 CONTINUE Z = B(M)-A(M)*D(MM1) IF (Z .NE. 0.) GO TO 102 Y(M) = 0. GO TO 103 102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z 103 CONTINUE DO 104 IP=1,MM1 I = M-IP Y(I) = Y(I)-D(I)*Y(I+1) 104 CONTINUE RETURN END C PROGRAM TESTF2 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT) C C --------------------- C TEST DRIVER FOR SEPX4 C --------------------- C C SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS. C USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-10). C C NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN C THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN. C ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON C A NEW COMPUTER. C C THE PROBLEMS ARE C C 1. SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION. C (PROBLEM A2 OF REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, BY=1 C C U = 3XY(1-X)(1-Y) EXP(X+Y) C C 2. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS; SOLUTION SAME AS IN PROBLEM 1. C (PROBLEM B2 OF REFERENCE) C C COEFU = -5 C U GIVEN ON BY=1 C UX GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=0 C C U = 3XY(1-X)(1-Y) EXP(X+Y) C C 3. POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT C ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION C HAS DISCONTINUOUS 3RD DERIVATIVES. C C COEFU = 0 C U GIVEN ON AX=0, AY=0 C UX GIVEN ON BX=1 C UY GIVEN ON BY=1 C C U = P(X)*P(Y) C C P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85. BETWEEN THESE C IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE C TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES. C C 4. SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = -100 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (P(X;10)+P(Y;20)/2 C C P(X;A) = COSH(A*X)/COSH(A) C C 5. DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS C SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0. C (PROBLEM F2 OF THE REFERENCE) C C COEFU = 0 C U GIVEN ON AX=0, BX=1, AY=0, AY=1 C C U = (X**1.5-X)*(Y**1.5-Y) C C 6. SMOOTH, PERIODIC HELMHOLTZ PROBLEM. C (PROBLEM C2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 7. SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY C CONDITIONS. C C COEFU = 0 C U GIVEN ON AX=0, BX=1 C UY GIVEN ON AY=-1, BY=1 C C U = T(Y)*( A(X) + T(Y)*B(X) ) C C T(Y) = 1-Y**2, A(X) = R*C(X) + EXP(SQRT(Q*X)), C B(X) = (7-P)*R/16/C(X), P = 14+SQRT(133), Q = 14-SQRT(133), C R = (7-Q)/R/SQRT(133), C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X)) C C 8. POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS; C SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0. C (PROBLEM E2 OF THE REFERNCE) C C COEFU = 0 C U GIVEN ON BX=1, BY=1 C UX GIVEN ON AX=0 C UY GIVEN ON AY=0 C C U = (X*Y)**2.5 C C 9. SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC C BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6. C (PROBLEM D2 OF THE REFERENCE) C C COEFU = -20 C U PERIODIC ON AX=0, BX=PI C U GIVEN ON AY=0 C UY GIVEN ON BY=PI C C U = COS(4Y) + SIN(4(X-Y)) C C 10. HOMOGENEOUS DIRICHLET PROBLEM; INCLUDED TO COLLECT TIMING C DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM. C C COEFU = 0 C U=0 ON AX=0, BX=1, AY=0, BY=1 C C C----------------------------------------------------------------------- C C C ... CONSTANTS C C NMAX = MAX GRID SIZE FOR THIS PROGRAM C NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID C LDXU,LDYU = REQUIRED DIMENSIONS FOR U C LUIN = INPUT UNIT FOR READS C LUOUT = OUTPUT UNIT FOR WRITES C PARAMETER (NRUNS=7, NMAX=2**NRUNS+1) PARAMETER (LDXU=NMAX, LDYU=NMAX) PARAMETER (NWORK = 2*NMAX**2 + 10*NMAX + NMAX/2 + 17) PARAMETER (LUIN=5, LUOUT=6) C INTEGER BCTY(4) REAL * COEFU, AX, BX, AY, BY, U(LDXU,LDYU), WORK(NWORK), * H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE C EXTERNAL PRHS, BRHS C C C----------------------------------------------------------------------- C C C SELECT ORDER OF ACCURACY C 5 CONTINUE WRITE(LUOUT,*) ' ENTER ORDER OF ACCURACY (2 OR 4) ' READ(LUIN,*) IORDER IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4)) GO TO 5 C C SELECT PROBLEM C 10 CONTINUE WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-10, 0 TO STOP) ' READ(LUIN,*) KPROB IF (KPROB .EQ. 0) STOP IF ((KPROB .LT. 0) .OR. (KPROB .GT. 10)) GO TO 10 C C SOLVE ON SEQUENCE OF GRIDS C WRITE(LUOUT,2000) KPROB,IORDER EOLD = 0.0E0 DO 500 K=3,NRUNS C C ... SETUP PROBLEM C NX = 2**K + 1 CALL SETUP(KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY) IF (NY .GT. NMAX) GO TO 10 C C ... SOLVE PROBLEM C CALL TIMER(T0) CALL FISH2(COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER, * U,LDXU,WORK,NWORK,INFO) CALL TIMER(T1) CPTIME = T1 - T0 C IF (INFO .NE. 0) THEN WRITE(LUOUT,2002) INFO GO TO 10 ENDIF C C ... COMPUTE ERROR C H = (BX-AX)/REAL(NX-1) CALL GETERR(AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX) C C ... COMPUTE CONVERGENCE RATE C IF (RELERR .LT. EOLD) THEN RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD)) ELSE RATE = 0.0E0 ENDIF C C ... PRINT SUMMARY C WRITE(LUOUT,2001) NX,NY,H,INFO,ABSERR,RELERR,TRUMAX,RATE, * CPTIME HOLD = H EOLD = RELERR 500 CONTINUE GO TO 10 C 2000 FORMAT(///' PROBLEM ',I2,7X,'MODULE FISH2',7X,'IORDER = ',I1 * //' NX NY',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR', * 6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,37('--') /) 2001 FORMAT(2X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,2X,0P,F4.1,1X,F6.2) 2002 FORMAT(/' SEPX4 RETURNS INFO = ',I3/) C END SUBROUTINE FISH2 (COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER, * U,LDXU,WORK,NWORK,INFO) C C----------------------------------------------------------------------- C C DRIVER FOR FISHPAK SUBPROGRAM SEPX4 C C----------------------------------------------------------------------- C INTEGER NX, NY, BCTY(4), IORDER, LDXU, INFO REAL * COEFU, PRHS, BRHS, AX, BX, AY, BY, U(LDXU,*), WORK(NWORK) REAL * CU, ALPHA, BETA, H, X, Y, PERTRB C COMMON / COEF / CU EXTERNAL COFX C C----------------------------------------------------------------------- C CU = COEFU M = NX-1 N = NY-1 ALPHA = 0.0E0 BETA = 0.0E0 H = (BX-AX)/REAL(M) C KBCA = BCTY(3) KBCB = BCTY(1) KBCC = BCTY(2) KBCD = BCTY(4) IF ((KBCA .EQ. 3) .AND. (KBCB .EQ. 3)) MBDCND = 0 IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 1)) MBDCND = 1 IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 2)) MBDCND = 2 IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 2)) MBDCND = 3 IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 1)) MBDCND = 4 IF ((KBCC .EQ. 3) .AND. (KBCD .EQ. 3)) NBDCND = 0 IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 1)) NBDCND = 1 IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 2)) NBDCND = 2 IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 2)) NBDCND = 3 IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 1)) NBDCND = 4 C LOC BDA = 1 LOC BDB = LOC BDA + NY LOC BDC = LOC BDB + NY LOC BDD = LOC BDC + NX LOC GRH = LOC BDD + NX LOC WRK = LOC GRH + LDXU*NY C IF (KBCA .EQ. 2) THEN K = LOC BDA - 1 DO 10 J=1,NY Y = AY + H*REAL(J-1) K = K + 1 WORK(K) = BRHS(3,AX,Y) 10 CONTINUE ENDIF C IF (KBCB .EQ. 2) THEN K = LOC BDB - 1 DO 20 J=1,NY Y = AY + H*REAL(J-1) K = K + 1 WORK(K) = BRHS(1,BX,Y) 20 CONTINUE ENDIF C IF (KBCC .EQ. 2) THEN K = LOC BDC - 1 DO 30 I=1,NX X = AX + H*REAL(I-1) K = K + 1 WORK(K) = BRHS(2,X,AY) 30 CONTINUE ENDIF C IF (KBCD .EQ. 2) THEN K = LOC BDD - 1 DO 40 I=1,NX X = AX + H*REAL(I-1) K = K + 1 WORK(K) = BRHS(4,X,BY) 40 CONTINUE ENDIF C IF (KBCA .EQ. 1) THEN DO 50 J=1,NY Y = AY + H*REAL(J-1) U(1,J) = BRHS(3,AX,Y) 50 CONTINUE ENDIF C IF (KBCB .EQ. 1) THEN DO 60 J=1,NY Y = AY + H*REAL(J-1) U(NX,J) = BRHS(1,BX,Y) 60 CONTINUE ENDIF C IF (KBCC .EQ. 1) THEN DO 70 I=1,NX X = AX + H*REAL(I-1) U(I,1) = BRHS(2,X,AY) 70 CONTINUE ENDIF C IF (KBCD .EQ. 1) THEN DO 80 I=1,NX X = AX + H*REAL(I-1) U(I,NY) = BRHS(4,X,BY) 80 CONTINUE ENDIF C DO 90 J=1,NY K = LOC GRH + (J-1)*LDXU - 1 Y = AY + H*REAL(J-1) DO 90 I=1,NX X = AX + H*REAL(I-1) K = K + 1 WORK(K) = PRHS(X,Y) 90 CONTINUE C WORK(LOCWRK) = REAL(NWORK - LOCWRK + 1) C CALL SEPX4(IORDER,AX,BX,M,MBDCND,WORK(LOCBDA),ALPHA,WORK(LOCBDB), * BETA,AY,BY,N,NBDCND,WORK(LOCBDC),WORK(LOCBDD),COFX, * WORK(LOCGRH),U,LDXU,WORK(LOCWRK),PERTRB,INFO) C RETURN END SUBROUTINE COFX (X,CUXX,CUX,CU) REAL * X, CUXX, CUX, CU, COEFU COMMON / COEF / COEFU CUXX = 1.0E0 CUX = 0.0E0 CU = COEFU RETURN END SUBROUTINE GETERR (AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX) C C ---------------------------------------------------------- C COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID C ---------------------------------------------------------- C REAL AX,AY,H,U(LDXU,*),ABSERR,RELERR,TRUMAX REAL X,Y,TRUSOL,DIFF C ABSERR = 0.0E0 TRUMAX = 0.0E0 DO 100 J=1,NY Y = AY + H*REAL(J-1) DO 100 I=1,NX X = AX + H*REAL(I-1) TRUSOL = TRUE(X,Y) ABSERR = MAX(ABS(TRUSOL-U(I,J)),ABSERR) TRUMAX = MAX(ABS(TRUSOL),TRUMAX) 100 CONTINUE C IF (TRUMAX .NE. 0.0E0) THEN RELERR = ABSERR/TRUMAX ELSE RELERR = ABSERR ENDIF RETURN END SUBROUTINE SETUP (KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY) C C --------------------------------------------------------- C SETUP PROBLEM KPROB (NX, NY, COEFU, AX, BX, AY, BY, BCTY) C --------------------------------------------------------- C INTEGER KPROB,NX,NY,BCTY(4) REAL * COEFU,AX,BX,AY,BY C COMMON /SELECT/ IPROB C IPROB = KPROB C C DEFAULT VALUES C NY = NX AX = 0.0E0 BX = 1.0E0 AY = 0.0E0 BY = 1.0E0 COEFU = 0.0E0 BCTY(1) = 1 BCTY(2) = 1 BCTY(3) = 1 BCTY(4) = 1 C C SELECT OPTIONS FOR EACH CASE C GO TO (100,200,300,400,500,600,700,800,900), IPROB GO TO 9999 C 100 CONTINUE GO TO 9999 C 200 CONTINUE COEFU = -5.0E0 BCTY(1) = 2 BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 300 CONTINUE BCTY(1) = 2 BCTY(4) = 2 GO TO 9999 C 400 CONTINUE COEFU = -100.0E0 BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 500 CONTINUE GO TO 9999 C 600 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(2) = 3 BCTY(3) = 3 BCTY(4) = 3 GO TO 9999 C 700 CONTINUE NY = 2*NX - 1 AY = -1.0E0 BCTY(2) = 2 BCTY(4) = 2 GO TO 9999 C 800 CONTINUE BCTY(2) = 2 BCTY(3) = 2 GO TO 9999 C 900 CONTINUE BX = 4.0E0*ATAN(1.0E0) BY = BX COEFU = -20.0E0 BCTY(1) = 3 BCTY(4) = 2 BCTY(3) = 3 GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION PRHS(X,Y) C C ---------------------------------------- C RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION C ---------------------------------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,600), IPROB C PRHS = 0.0E0 GO TO 9999 C 100 CONTINUE PRHS = 6.0E0*X*Y*EXP(X+Y)*(X*Y+X+Y-3.) GO TO 9999 C 200 CONTINUE PRHS = X*Y*EXP(X+Y)*(6.0E0*(X*Y+X+Y-3.0E0) * - 15.0E0*(1.0E0-X)*(1.0E0-Y)) GO TO 9999 C 300 CONTINUE PRHS = D2P(X)*P(Y) + P(X)*D2P(Y) GO TO 9999 C 400 CONTINUE PRHS = 150.0E0*COSH(20.0E0*Y)/COSH(20.0E0) GO TO 9999 C 500 CONTINUE C = -0.18750E0 A = 0.750E0 AM2 = A - 2.0E0 IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0)) THEN PRHS = C*(X**AM2*(Y**A-Y) + Y**AM2*(X**A-X)) ELSE PRHS = 0.0E0 ENDIF GO TO 9999 C 600 CONTINUE B = 4.0E0 B2 = B*B PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y)) * - (B2+20.0E0)*COS(B*Y) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y DEK1X = RK1*RK1*EK1X DEK2X = RK2*RK2*EK2X DEDIFF = DEK1X-DEK2X DDF1 = A*DEDIFF + DEK2X DDF2 = B*DEDIFF UXX = Y21*(DDF1 + Y21*DDF2) UYY = -2.0E0*(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2) PRHS = UXX + UYY GO TO 9999 C 800 CONTINUE PRHS = 3.750E0*(SQRT(X*Y**5) + SQRT(Y*X**5)) GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION BRHS (K,X,Y) C C -------------------------------------- C RIGHT-HAND SIDE OF BOUNDARY CONDITIONS C -------------------------------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,200,300,400,500,600,700,800,900), IPROB C BRHS = 0.0E0 GO TO 9999 C 100 CONTINUE BRHS = 0.0E0 GO TO 9999 C 200 CONTINUE GO TO (210,220,210,240), K 210 BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*X)*Y*(1.0E0-Y) GO TO 9999 220 BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*Y)*X*(1.0E0-X) GO TO 9999 240 BRHS = 0.0E0 GO TO 9999 C 300 CONTINUE GO TO (310,320,320,310), K 310 BRHS = 0.0E0 GO TO 9999 320 BRHS = TRUE(X,Y) GO TO 9999 C 400 CONTINUE GO TO (420,410,410,420), K 410 BRHS = 0.0E0 GO TO 9999 420 BRHS = TRUE(X,Y) GO TO 9999 C 500 CONTINUE BRHS = TRUE(X,Y) GO TO 9999 C 600 CONTINUE GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y GO TO (710,720,710,720), K 710 BRHS = Y21*(F1 + Y21*F2) GO TO 9999 720 BRHS = -2.0E0*Y*(F1 + 2.0E0*Y21*F2) GO TO 9999 C 800 CONTINUE GO TO (810,820,820,810), K 810 BRHS = SQRT((X*Y)**5) GO TO 9999 820 BRHS = 0.0E0 GO TO 9999 C 900 CONTINUE IF (K .EQ. 2) THEN BRHS = TRUE(X,Y) ELSE BRHS = -4.0E0*COS(4.0E0*X) ENDIF GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION TRUE(X,Y) C C ------------- C TRUE SOLUTION C ------------- C REAL X,Y C COMMON /SELECT/ IPROB C GO TO (100,100,300,400,500,600,700,800,600), IPROB C TRUE = 0.0E0 GO TO 9999 C 100 CONTINUE TRUE = 3.0E0*EXP(X+Y)*X*Y*(1.0E0-X)*(1.0E0-Y) GO TO 9999 C 300 CONTINUE TRUE = P(X)*P(Y) GO TO 9999 C 400 CONTINUE TRUE = (COSH(10.E0*X)/COSH(10.0E0)+COSH(20.0E0*Y)/COSH(20.0E0)) * /2.0E0 GO TO 9999 C 500 CONTINUE A = 0.750E0 TRUE = (X**A-X)*(Y**A-Y) GO TO 9999 C 600 CONTINUE B = 4.0E0 TRUE = COS(B*Y) + SIN(B*(X-Y)) GO TO 9999 C 700 CONTINUE S133 = SQRT(133.0E0) RK1 = SQRT(14.0E0+S133) RK2 = SQRT(14.0E0-S133) A = (-7.0E0+S133)/(2.0E0*S133) B = (-7.0E0-S133)*A/16.0E0 EK1X = EXP(RK1*X) EK2X = EXP(RK2*X) EDIFF = EK1X-EK2X F1 = A*EDIFF + EK2X F2 = B*EDIFF Y21 = 1.0E0 - Y*Y TRUE = Y21*(F1 + Y21*F2) GO TO 9999 C 800 CONTINUE TRUE = SQRT((X*Y)**5) GO TO 9999 C 9999 CONTINUE RETURN END REAL FUNCTION P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 20 DZ = Z2 - Z1 P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ * + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3 RETURN 10 CONTINUE P = 1.0E0 RETURN 20 CONTINUE P = 0.0E0 RETURN END REAL FUNCTION D2P (Z) Z1 = 0.150E0 Z2 = 0.850E0 IF (Z .LE. Z1) GO TO 10 IF (Z .GE. Z2) GO TO 10 DZ = Z2 - Z1 C3 = -1.0E0/DZ**3 C4 = 3.0E0/DZ**4 C5 = -6.0E0/DZ**5 ZMZ1 = Z - Z1 ZMZ2 = Z - Z2 ZMZ12 = ZMZ1*ZMZ1 ZMZ22 = ZMZ2*ZMZ2 D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22 * + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1 RETURN 10 CONTINUE D2P = 0.0E0 RETURN END SUBROUTINE TIMER (T) C C ------------------------------------------------ C RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC) C ------------------------------------------------ C REAL T T = SECOND() RETURN END C FISHPAK13 FROM PORTLIB 03/12/81 SUBROUTINE SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, 1NBDCND,BDC,BDD,COFX,GRHS,USOL,IDMN,W,PERTRB,IERROR) C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3.1 , OCTOBER 1980) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C C C DIMENSION OF BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), C ARGUMENTS USOL(IDMN,N+1), GRHS(IDMN,N+1), C W (SEE ARGUMENT LIST) C C LATEST REVISION OCTOBER 1980 C C C PURPOSE SEPX4 SOLVES FOR EITHER THE SECOND-ORDER C FINITE DIFFERENCE APPROXIMATION OR A C A FOURTH-ORDER APPROXIMATION TO THE C SOLUTION OF A SEPARABLE ELLIPTIC EQUATION C AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y) C C ON A RECTANGLE (X GREATER THAN OR EQUAL TO A C AND LESS THAN OR EQUAL TO B; Y GREATER THAN C OR EQUAL TO C AND LESS THAN OR EQUAL TO D). C ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY C CONDITIONS IS ALLOWED. C IF BOUNDARY CONDITIONS IN THE X DIRECTION C ARE PERIODIC (SEE MBDCND=0 BELOW) THEN THE C COEFFICIENTS MUST SATISFY C AF(X)=C1,BF(X)=0,CF(X)=C2 FOR ALL X. C HERE C1,C2 ARE CONSTANTS, C1.GT.0. C C THE POSSIBLE BOUNDARY CONDITIONS ARE C IN THE X-DIRECTION: C (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL Y,X C (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR ALL Y C (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE C SPECIFIED FOR ALL Y C (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+ C BETA*U(B,Y) ARE SPECIFIED FOR ALL Y C (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE C SPECIFIED FOR ALL Y C C IN THE Y-DIRECTION: C (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y C (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X C (2) U(X,C),DU(X,D)/DY ARE SPECIFIED FOR ALL X C (3) DU(X,C)/DY,DU(X,D)/DY ARE SPECIFIED FOR C ALL X C (4) DU(X,C)/DY,U(X,D) ARE SPECIFIED FOR ALL X C C USAGE CALL SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB, C BETA,C,D,N,NBDCND,BDC,BDD,COFX, C GRHS,USOL,IDMN,W,PERTRB,IERROR) C C ARGUMENTS C C C IORDER C = 2 IF A SECOND-ORDER APPROXIMATION IS SOUGHT C = 4 IF A FOURTH-ORDER APPROXIMATION IS SOUGHT C C A,B C THE RANGE OF THE X-INDEPENDENT VARIABLE; C I.E., X IS GREATER THAN OR EQUAL TO A AND C LESS THAN OR EQUAL TO B. A MUST BE LESS THAN C B. C C M C THE NUMBER OF PANELS INTO WHICH THE INTERVAL C [A,B] IS SUBDIVIDED. HENCE, THERE WILL BE C M+1 GRID POINTS IN THE X-DIRECTION GIVEN BY C XI=A+(I-1)*DLX FOR I=1,2,...,M+1 WHERE C DLX=(B-A)/M IS THE PANEL WIDTH. M MUST BE C LESS THAN IDMN AND GREATER THAN 5. C C MBDCND C INDICATES THE TYPE OF BOUNDARY CONDITION AT C X=A AND X=B C = 0 IF THE SOLUTION IS PERIODIC IN X; I.E., C U(X+B-A,Y)=U(X,Y) FOR ALL Y,X C = 1 IF THE SOLUTION IS SPECIFIED AT X=A AND C X=B; I.E., U(A,Y) AND U(B,Y) ARE C SPECIFIED FOR ALL Y C = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND C THE BOUNDARY CONDITION IS MIXED AT X=B; C I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y) C ARE SPECIFIED FOR ALL Y C = 3 IF THE BOUNDARY CONDITIONS AT X=A AND X=B C ARE MIXED; I.E., DU(A,Y)/DX+ALPHA*U(A,Y) C AND DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED C FOR ALL Y C = 4 IF THE BOUNDARY CONDITION AT X=A IS MIXED C AND THE SOLUTION IS SPECIFIED AT X=B; C I.E., DU(A,Y)/DX+ALPHA*U(A,Y) AND U(B,Y) C ARE SPECIFIED FOR ALL Y C C BDA C A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT C SPECIFIES THE VALUES OF DU(A,Y)/DX+ C ALPHA*U(A,Y) AT X=A, WHEN MBDCND=3 OR 4. C BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ); C J=1,2,...,N+1 C WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A C DUMMY PARAMETER. C C ON INPUT ALPHA C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT X=A (SEE C ARGUMENT BDA). IF MBDCND " 3,4 THEN ALPHA IS C A DUMMY PARAMETER. C C BDB C A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT C SPECIFIES THE VALUES OF DU(B,Y)/DX+ C BETA*U(B,Y) AT X=B. WHEN MBDCND=2 OR 3 C BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ); C J=1,2,...,N+1 C WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A C DUMMY PARAMETER. C C BETA C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT X=B (SEE C ARGUMENT BDB). IF MBDCND"2,3 THEN BETA IS A C DUMMY PARAMETER. C C C,D C THE RANGE OF THE Y-INDEPENDENT VARIABLE; C I.E., Y IS GREATER THAN OR EQUAL TO C AND C LESS THAN OR EQUAL TO D. C MUST BE LESS THAN C D. C C N C THE NUMBER OF PANELS INTO WHICH THE INTERVAL C [C,D] IS SUBDIVIDED. HENCE, THERE WILL BE C N+1 GRID POINTS IN THE Y-DIRECTION GIVEN BY C YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE C DLY=(D-C)/N IS THE PANEL WIDTH. IN ADDITION, C N MUST BE GREATER THAN 4. C C NBDCND C INDICATES THE TYPES OF BOUNDARY CONDITIONS AT C Y=C AND Y=D C = 0 IF THE SOLUTION IS PERIODIC IN Y; I.E., C U(X,Y+D-C)=U(X,Y) FOR ALL X,Y C = 1 IF THE SOLUTION IS SPECIFIED AT Y=C AND C Y = D, I.E., U(X,C) AND U(X,D) ARE C SPECIFIED FOR ALL X C = 2 IF THE SOLUTION IS SPECIFIED AT Y=C AND C THE BOUNDARY CONDITION IS MIXED AT Y=D; C I.E., DU(X,C)/DY AND U(X,D) C ARE SPECIFIED FOR ALL X C = 3 IF THE BOUNDARY CONDITIONS ARE MIXED AT C Y=CAND Y=D I.E., DU(X,D)/DY C AND DU(X,D)/DY ARE SPECIFIED C FOR ALL X C = 4 IF THE BOUNDARY CONDITION IS MIXED AT Y=C C AND THE SOLUTION IS SPECIFIED AT Y=D; C I.E. DU(X,C)/DY+GAMA*U(X,C) AND U(X,D) C ARE SPECIFIED FOR ALL X C C BDC C A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT C SPECIFIES THE VALUE DU(X,C)/DY C AT Y=C. WHEN NBDCND=3 OR 4 C BDC(I) = DU(XI,C)/DY C I=1,2,...,M+1. C WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A C DUMMY PARAMETER. C C C BDD C A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT C SPECIFIED THE VALUE OF DU(X,D)/DY C AT Y=D. WHEN NBDCND=2 OR 3 C BDD(I)=DU(XI,D)/DY C I=1,2,...,M+1. C WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A C DUMMY PARAMETER. C C C COFX C A USER-SUPPLIED SUBPROGRAM WITH C PARAMETERS X, AFUN, BFUN, CFUN WHICH C RETURNS THE VALUES OF THE X-DEPENDENT C COEFFICIENTS AF(X), BF(X), CF(X) IN C THE ELLIPTIC EQUATION AT X. C IF BOUNDARY CONDITIONS IN THE X DIRECTION C ARE PERIODIC THEN THE COEFFICIENTS C MUST SATISFY AF(X)=C1,BF(X)=0,CF(X)=C2 FOR C ALL X. HERE C1.GT.0 AND C2 ARE CONSTANTS. C C NOTE THAT COFX MUST BE DECLARED EXTERNAL C IN THE CALLING ROUTINE. C C GRHS C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE C VALUES OF THE RIGHT-HAND SIDE OF THE ELLIPTIC C EQUATION; I.E., GRHS(I,J)=G(XI,YI), FOR C I=2,...,M; J=2,...,N. AT THE BOUNDARIES, C GRHS IS DEFINED BY C C MBDCND GRHS(1,J) GRHS(M+1,J) C ------ --------- ----------- C 0 G(A,YJ) G(B,YJ) C 1 * * C 2 * G(B,YJ) J=1,2,...,N+1 C 3 G(A,YJ) G(B,YJ) C 4 G(A,YJ) * C C NBDCND GRHS(I,1) GRHS(I,N+1) C ------ --------- ----------- C 0 G(XI,C) G(XI,D) C 1 * * C 2 * G(XI,D) I=1,2,...,M+1 C 3 G(XI,C) G(XI,D) C 4 G(XI,C) * C C WHERE * MEANS THESE QUANTITES ARE NOT USED. C GRHS SHOULD BE DIMENSIONED IDMN BY AT LEAST C N+1 IN THE CALLING ROUTINE. C C USOL C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE C VALUES OF THE SOLUTION ALONG THE BOUNDARIES. C AT THE BOUNDARIES, USOL IS DEFINED BY C C MBDCND USOL(1,J) USOL(M+1,J) C ------ --------- ----------- C 0 * * C 1 U(A,YJ) U(B,YJ) C 2 U(A,YJ) * J=1,2,...,N+1 C 3 * * C 4 * U(B,YJ) C C NBDCND USOL(I,1) USOL(I,N+1) C ------ --------- ----------- C 0 * * C 1 U(XI,C) U(XI,D) C 2 U(XI,C) * I=1,2,...,M+1 C 3 * * C 4 * U(XI,D) C C WHERE * MEANS THE QUANTITES ARE NOT USED IN C THE SOLUTION. C C IF IORDER=2, THE USER MAY EQUIVALENCE GRHS C AND USOL TO SAVE SPACE. NOTE THAT IN THIS C CASE THE TABLES SPECIFYING THE BOUNDARIES OF C THE GRHS AND USOL ARRAYS DETERMINE THE C BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS. C IF THE TABLES CALL FOR BOTH G(X,Y) AND C U(X,Y) AT A CORNER THEN THE SOLUTION MUST BE C CHOSEN. FOR EXAMPLE, IF MBDCND=2 AND C NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST BE C CHOSEN AT THE CORNERS IN ADDITION TO G(B,C). C C IF IORDER=4, THEN THE TWO ARRAYS, USOL AND C GRHS, MUST BE DISTINCT. C C USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST C N+1 IN THE CALLING ROUTINE. C C IDMN C THE ROW (OR FIRST) DIMENSION OF THE ARRAYS C GRHS AND USOL AS IT APPEARS IN THE PROGRAM C CALLING SEPX4. THIS PARAMETER IS USED TO C SPECIFY THE VARIABLE DIMENSION OF GRHS AND C USOL. IDMN MUST BE AT LEAST 7 AND GREATER C THAN OR EQUAL TO M+1. C C W C A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED C BY THE USER FOR WORK SPACE. C 10*N+(16+INT(LOG2(N)))*(M+1)+23 WILL SUFFICE C AS A LENGTH FOR W. THE ACTUAL LENGTH OF C W IN THE CALLING ROUTINE MUST BE SET IN W(1) C (SEE IERROR=11). C ON OUTPUT USOL C CONTAINS THE APPROXIMATE SOLUTION TO THE C ELLIPTIC EQUATION. USOL(I,J) IS THE C APPROXIMATION TO U(XI,YJ) FOR I=1,2...,M+1 C AND J=1,2,...,N+1. THE APPROXIMATION HAS C ERROR O(DLX**2+DLY**2) IF CALLED WITH C IORDER=2 AND O(DLX**4+DLY**4) IF CALLED WITH C IORDER=4. C C W C CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE C DESTROYED IF SEPX4 IS CALLED AGAIN WITH C INTL=1. IN ADDITION W(1) CONTAINS THE EXACT C MINIMAL LENGTH (IN FLOATING POINT) REQUIRED C FOR THE WORK SPACE (SEE IERROR=11). C C PERTRB C IF A COMBINATION OF PERIODIC OR DERIVATIVE C BOUNDARY CONDITIONS (I.E., ALPHA=BETA=0 IF C MBDCND=3) IS SPECIFIED AND IF CF(X)=0 FOR ALL X C THEN A SOLUTION TO THE DISCRETIZED MATRIX C EQUATION MAY NOT EXIST (REFLECTING THE NON- C UNIQUENESS OF SOLUTIONS TO THE PDE). PERTRB C IS A CONSTANT CALCULATED AND SUBTRACTED FROM C THE RIGHT HAND SIDE OF THE MATRIX EQUATION C INSURING THE EXISTENCE OF A SOLUTION. C SEPX4 COMPUTES THIS SOLUTION WHICH IS A C WEIGHTED MINIMAL LEAST SQUARES SOLUTION TO C THE ORIGINAL PROBLEM. IF SINGULARITY IS C NOT DETECTED PERTRB=0.0 IS RETURNED BY C SEPX4. C C IERROR C AN ERROR FLAG THAT INDICATES INVALID INPUT C PARAMETERS OR FAILURE TO FIND A SOLUTION C = 0 NO ERROR C = 1 IF A GREATER THAN B OR C GREATER THAN D C = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER C THAN 4 C = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER C THAN 4 C = 4 IF ATTEMPT TO FIND A SOLUTION FAILS. C (THE LINEAR SYSTEM GENERATED IS NOT C DIAGONALLY DOMINANT.) C = 5 IF IDMN IS TOO SMALL (SEE DISCUSSION OF C IDMN) C = 6 IF M IS TOO SMALL OR TOO LARGE (SEE C DISCUSSION OF M) C = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N) C = 8 IF IORDER IS NOT 2 OR 4 C = 9 IF INTL IS NOT 0 OR 1 C = 10 IF AFUN IS LESS THAN OR EQUAL TO ZERO C FOR SOME INTERIOR MESH POINT XI C SOME INTERIOR MESH POINT (XI,YJ) C = 11 IF THE WORK SPACE LENGTH INPUT IN W(1) C IS LESS THAN THE EXACT MINIMAL WORK C SPACE LENGTH REQUIRED OUTPUT IN W(1). C = 12 IF MBDCND=0 AND AF(X)=CF(X)=CONSTANT C OR BF(X)=0 FOR ALL X IS NOT TRUE. C C C SPECIAL CONDITIONS NONE C C COMMON BLOCKS SPL4 C C I/O NONE C C PRECISION SINGLE C C REQUIRED LIBRARY NONE C FILES C C SPECIALIST JOHN C. ADAMS, NCAR, BOULDER, COLORADO 80307 C C LANGUAGE FORTRAN C C C ENTRY POINTS SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4, C DEFE4,DX4,DY4 C C HISTORY SEPX4 WAS DEVELOPED BY MODIFYING THE ULIB C ROUTINE SEPELI DURING OCTOBER 1978. C IT SHOULD BE USED INSTEAD OF SEPELI WHENEVER C POSSIBLE. THE INCREASE IN SPEED IS AT LEAST C A FACTOR OF THREE. C C ALGORITHM SEPX4 AUTOMATICALLY DISCRETIZES THE SEPARABLE C ELLIPTIC EQUATION WHICH IS THEN SOLVED BY A C GENERALIZED CYCLIC REDUCTION ALGORITHM IN THE C SUBROUTINE POIS. THE FOURTH ORDER SOLUTION C IS OBTAINED USING THE TECHNIQUE OF C DEFFERRED CORRECTIONS REFERENCED BELOW. C C C REFERENCES KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT C BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968), C WALTHAM, MASS. C C SWARZTRAUBER, P., AND R. SWEET (1975): C EFFICIENT FORTRAN SUBPROGRAMS FOR THE C SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL C EQUATIONS. NCAR TECHNICAL NOTE C NCAR-TN/IA-109, PP. 135-137. C C C C DIMENSION GRHS(IDMN,1) ,USOL(IDMN,1) DIMENSION BDA(1) ,BDB(1) ,BDC(1) ,BDD(1) , 1 W(1) EXTERNAL COFX C C CHECK INPUT PARAMETERS C CALL CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR) IF (IERROR .NE. 0) RETURN C C COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT C L = N+1 IF (NBDCND .EQ. 0) L = N K = M+1 L = N+1 C ESTIMATE LOG BASE 2 OF N LOG2N=INT(ALOG(FLOAT(N+1))/ALOG(2.0)+0.5) LENGTH=4*(N+1)+(10+LOG2N)*(M+1) IERROR = 11 LINPUT = INT(W(1)+0.5) LOUTPT = LENGTH+6*(K+L)+1 W(1) = FLOAT(LOUTPT) IF (LOUTPT .GT. LINPUT) RETURN IERROR = 0 C C SET WORK SPACE INDICES C I1 = LENGTH+2 I2 = I1+L I3 = I2+L I4 = I3+L I5 = I4+L I6 = I5+L I7 = I6+L I8 = I7+K I9 = I8+K I10 = I9+K I11 = I10+K I12 = I11+K I13 = 2 CALL SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, 1NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3), 2 W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), 3 W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR) RETURN END SUBROUTINE SPELI4(IORDER,A,B,M,MBDCND, 1BDA,ALPHA,BDB,BETA,C,D,N,NBDCND,BDC,BDD,COFX,AN,BN, 2 CN,DN,UN,ZN,AM,BM,CM,DM,UM,ZM,GRHS,USOL,IDMN, 3 W,PERTRB,IERROR) C C SPELI4 SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI C AND COMPUTES A SECOND ORDER SOLUTION IN USOL. A RETURN JUMP TO C SEPX4 OCCURRS IF IORDER=2. IF IORDER=4 A FOURTH ORDER C SOLUTION IS GENERATED IN USOL. C DIMENSION BDA(1) ,BDB(1) ,BDC(1) ,BDD(1) , 1 W(1) DIMENSION GRHS(IDMN,1) ,USOL(IDMN,1) DIMENSION AN(1) ,BN(1) ,CN(1) ,DN(1) , 1 UN(1) ,ZN(1) DIMENSION AM(1) ,BM(1) ,CM(1) ,DM(1) , 1 UM(1) ,ZM(1) COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR EXTERNAL COFX C C C SET PARAMETERS INTERNALLY C KSWX = MBDCND+1 KSWY = NBDCND+1 K = M+1 L = N+1 AIT = A BIT = B CIT = C DIT = D DLY=(DIT-CIT)/FLOAT(N) C C SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR C AND NON-SPECIFIED BOUNDARIES. C DO 20 I=2,M DO 10 J=2,N USOL(I,J)=DLY**2*GRHS(I,J) 10 CONTINUE 20 CONTINUE IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO 40 DO 30 J=2,N USOL(1,J)=DLY**2*GRHS(1,J) 30 CONTINUE 40 CONTINUE IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO 60 DO 50 J=2,N USOL(K,J)=DLY**2*GRHS(K,J) 50 CONTINUE 60 CONTINUE IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO 80 DO 70 I=2,M USOL(I,1)=DLY**2*GRHS(I,1) 70 CONTINUE 80 CONTINUE IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100 DO 90 I=2,M USOL(I,L)=DLY**2*GRHS(I,L) 90 CONTINUE 100 CONTINUE IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3) 1USOL(1,1)=DLY**2*GRHS(1,1) IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3) 1USOL(K,1)=DLY**2*GRHS(K,1) IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5) 1USOL(1,L)=DLY**2*GRHS(1,L) IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5) 1USOL(K,L)=DLY**2*GRHS(K,L) I1 = 1 C C SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES C MP=1 IF(KSWX.EQ.1) MP=0 NP=NBDCND C C SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED C IN NINT,MINT C DLX = (BIT-AIT)/FLOAT(M) MIT = K-1 IF (KSWX .EQ. 2) MIT = K-2 IF (KSWX .EQ. 4) MIT = K DLY = (DIT-CIT)/FLOAT(N) NIT = L-1 IF (KSWY .EQ. 2) NIT = L-2 IF (KSWY .EQ. 4) NIT = L TDLX3 = 2.0*DLX**3 DLX4 = DLX**4 TDLY3 = 2.0*DLY**3 DLY4 = DLY**4 C C SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI C IS = 1 JS = 1 IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2 IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2 NS = NIT+JS-1 MS = MIT+IS-1 C C SET X - DIRECTION C DO 110 I=1,MIT XI = AIT+FLOAT(IS+I-2)*DLX CALL COFX (XI,AI,BI,CI) AXI = (AI/DLX-0.5*BI)/DLX BXI = -2.*AI/DLX**2+CI CXI = (AI/DLX+0.5*BI)/DLX AM(I)=DLY**2*AXI BM(I)=DLY**2*BXI CM(I)=DLY**2*CXI 110 CONTINUE C C SET Y DIRECTION C DO 120 J=1,NIT DYJ=1.0 EYJ=-2.0 FYJ=1.0 AN(J) = DYJ BN(J) = EYJ CN(J) = FYJ 120 CONTINUE C C ADJUST EDGES IN X DIRECTION UNLESS PERIODIC C AX1 = AM(1) CXM = CM(MIT) GO TO (170,130,150,160,140),KSWX C C DIRICHLET-DIRICHLET IN X DIRECTION C 130 AM(1) = 0.0 CM(MIT) = 0.0 GO TO 170 C C MIXED-DIRICHLET IN X DIRECTION C 140 AM(1) = 0.0 BM(1) = BM(1)+2.*ALPHA*DLX*AX1 CM(1) = CM(1)+AX1 CM(MIT) = 0.0 GO TO 170 C C DIRICHLET-MIXED IN X DIRECTION C 150 AM(1) = 0.0 AM(MIT) = AM(MIT)+CXM BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM CM(MIT) = 0.0 GO TO 170 C C MIXED - MIXED IN X DIRECTION C 160 CONTINUE AM(1) = 0.0 BM(1) = BM(1)+2.*DLX*ALPHA*AX1 CM(1) = CM(1)+AX1 AM(MIT) = AM(MIT)+CXM BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM CM(MIT) = 0.0 170 CONTINUE C C ADJUST IN Y DIRECTION UNLESS PERIODIC C DY1 = AN(1) FYN = CN(NIT) GAMA=0.0 XNU=0.0 GO TO (220,180,200,210,190),KSWY C C DIRICHLET-DIRICHLET IN Y DIRECTION C 180 CONTINUE AN(1) = 0.0 CN(NIT) = 0.0 GO TO 220 C C MIXED-DIRICHLET IN Y DIRECTION C 190 CONTINUE AN(1) = 0.0 BN(1) = BN(1)+2.*DLY*GAMA*DY1 CN(1) = CN(1)+DY1 CN(NIT) = 0.0 GO TO 220 C C DIRICHLET-MIXED IN Y DIRECTION C 200 AN(1) = 0.0 AN(NIT) = AN(NIT)+FYN BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN CN(NIT) = 0.0 GO TO 220 C C MIXED - MIXED DIRECTION IN Y DIRECTION C 210 CONTINUE AN(1) = 0.0 BN(1) = BN(1)+2.*DLY*GAMA*DY1 CN(1) = CN(1)+DY1 AN(NIT) = AN(NIT)+FYN BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN CN(NIT) = 0.0 220 IF (KSWX .EQ. 1) GO TO 270 C C ADJUST USOL ALONG X EDGE C DO 260 J=JS,NS IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230 USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J) GO TO 240 230 USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J) 240 IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250 USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J) GO TO 260 250 USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J) 260 CONTINUE 270 IF (KSWY .EQ. 1) GO TO 320 C C ADJUST USOL ALONG Y EDGE C DO 310 I=IS,MS IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280 USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1) GO TO 290 280 USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I) 290 IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300 USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L) GO TO 310 300 USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I) 310 CONTINUE 320 CONTINUE C C SAVE ADJUSTED EDGES IN GRHS IF IORDER=4 C IF (IORDER .NE. 4) GO TO 350 DO 330 J=JS,NS GRHS(IS,J) = USOL(IS,J) GRHS(MS,J) = USOL(MS,J) 330 CONTINUE DO 340 I=IS,MS GRHS(I,JS) = USOL(I,JS) GRHS(I,NS) = USOL(I,NS) 340 CONTINUE 350 CONTINUE IORD = IORDER PERTRB = 0.0 C C CHECK IF OPERATOR IS SINGULAR C CALL CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR) C C COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE C IF SINGULAR C IF (SINGLR) CALL TRIS4 (MIT,AM,BM,CM,DM,UM,ZM) IF (SINGLR) CALL TRIS4 (NIT,AN,BN,CN,DN,UN,ZN) C C ADJUST RIGHT HAND SIDE IF NECESSARY C 360 CONTINUE IF (SINGLR) CALL ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB) C C COMPUTE SOLUTION C C SAVE ADJUSTED RIGHT HAND SIDE IN GRHS DO 444 J=JS,NS DO 444 I=IS,MS GRHS(I,J)=USOL(I,J) 444 CONTINUE CALL GENBUN(NP,NIT,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),IEROR,W) C CHECK IF ERROR DETECTED IN POIS C THIS CAN ONLY CORRESPOND TO IERROR=12 IF(IEROR.EQ.0) GO TO 224 C SET ERROR FLAG IF IMPROPER COEFFICIENTS INPUT TO POIS IERROR=12 RETURN 224 CONTINUE IF (IERROR .NE. 0) RETURN C C SET PERIODIC BOUNDARIES IF NECESSARY C IF (KSWX .NE. 1) GO TO 380 DO 370 J=1,L USOL(K,J) = USOL(1,J) 370 CONTINUE 380 IF (KSWY .NE. 1) GO TO 400 DO 390 I=1,K USOL(I,L) = USOL(I,1) 390 CONTINUE 400 CONTINUE C C MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES C NORM IF OPERATOR IS SINGULAR C IF (SINGLR) CALL MINSO4 (USOL,IDMN,ZN,ZM,PRTRB) C C RETURN IF DEFE4RED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE C NOT FLAGGED C IF (IORD .EQ. 2) RETURN IORD = 2 C C COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION C CALL DEFE4(COFX,IDMN,USOL,GRHS) GO TO 360 END SUBROUTINE CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERR 1OR) EXTERNAL COFX C C THIS PROGRAM CHECKS THE INPUT PARAMETERS FOR ERRORS C C C C CHECK DEFINITION OF SOLUTION REGION C IERROR = 1 IF (A.GE.B .OR. C.GE.D) RETURN C C CHECK BOUNDARY SWITCHES C IERROR = 2 IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN IERROR = 3 IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN C C CHECK FIRST DIMENSION IN CALLING ROUTINE C IERROR = 5 IF (IDMN .LT. 7) RETURN C C CHECK M C IERROR = 6 IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN C C CHECK N C IERROR = 7 IF (N .LT. 5) RETURN C C CHECK IORDER C IERROR = 8 IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN C C CHECK INTL C C C CHECK THAT EQUATION IS ELLIPTIC C DLX = (B-A)/FLOAT(M) DO 30 I=2,M XI = A+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) IF (AI.GT.0.0) GO TO 10 IERROR=10 RETURN 10 CONTINUE 30 CONTINUE C C NO ERROR FOUND C IERROR = 0 RETURN END SUBROUTINE TRIS4 (N,A,B,C,D,U,Z) C C THIS SUBROUTINE SOLVES FOR A NON-ZERO EIGENVECTOR CORRESPONDING C TO THE ZERO EIGENVALUE OF THE TRANSPOSE OF THE RANK C DEFICIENT ONE MATRIX WITH SUBDIAGONAL A, DIAGONAL B, AND C SUPERDIAGONAL C , WITH A(1) IN THE (1,N) POSITION, WITH C C(N) IN THE (N,1) POSITION, AND ALL OTHER ELEMENTS ZERO. C DIMENSION A(N) ,B(N) ,C(N) ,D(N) , 1 U(N) ,Z(N) BN = B(N) D(1) = A(2)/B(1) V = A(1) U(1) = C(N)/B(1) NM2 = N-2 DO 10 J=2,NM2 DEN = B(J)-C(J-1)*D(J-1) D(J) = A(J+1)/DEN U(J) = -C(J-1)*U(J-1)/DEN BN = BN-V*U(J-1) V = -V*D(J-1) 10 CONTINUE DEN = B(N-1)-C(N-2)*D(N-2) D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN AN = C(N-1)-V*D(N-2) BN = BN-V*U(N-2) DEN = BN-AN*D(N-1) C C SET LAST COMPONENT EQUAL TO ONE C Z(N) = 1.0 Z(N-1) = -D(N-1) NM1 = N-1 DO 20 J=2,NM1 K = N-J Z(K) = -D(K)*Z(K+1)-U(K)*Z(N) 20 CONTINUE RETURN END SUBROUTINE ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB) C C THIS SUBROUTINE ORTHO4ONALIZES THE ARRAY USOL WITH RESPECT TO C THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,1) ,ZN(1) ,ZM(1) ISTR = IS IFNL = MS JSTR = JS JFNL = NS C C COMPUTE WEIGHTED INNER PRODUCTS C UTE = 0.0 ETE = 0.0 DO 20 I=IS,MS II = I-IS+1 DO 10 J=JS,NS JJ = J-JS+1 ETE = ETE+ZM(II)*ZN(JJ) UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) 10 CONTINUE 20 CONTINUE C C SET PERTURBATION PARAMETER C PERTRB = UTE/ETE C C SUBTRACT OFF CONSTANT PERTRB C DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE DEFE4(COFX,IDMN,USOL,GRHS) C C THIS SUBROUTINE FIRST APPROXIMATES THE TRUN1ATION ERROR GIVEN BY C TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE C TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND C AT THE BOUNDARIES IF PERIODIC(HERE UXXX,UXXXX ARE THE THIRD C AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X). C TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) C AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED. C TX=0.0 ALONG SPECIFIED BOUNDARIES. TY HAS SYMMETRIC FORM C IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y). C THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE C (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUN1ATION ERROR C AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS C AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT C HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION. C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION GRHS(IDMN,1) ,USOL(IDMN,1) EXTERNAL COFX C C C COMPUTE TRUN1ATION ERROR APPROXIMATION OVER THE ENTIRE MESH C DO 30 I=IS,MS XI = AIT+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) DO 30 J=JS,NS C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) C CALL DX4(USOL,IDMN,I,J,UXXX,UXXXX) CALL DY4(USOL,IDMN,I,J,UYYY,UYYYY) TX = AI*UXXXX/12.0+BI*UXXX/6.0 TY=UYYYY/12.0 C C RESET FORM OF TRUN1ATION IF AT BOUNDARY WHICH IS NON-PERIODIC C IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO 10 TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) 10 IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO 20 TY = (UYYYY/4.0+UYYY/DLY)/3.0 20 GRHS(I,J)=GRHS(I,J)+DLY**2*(DLX**2*TX+DLY**2*TY) 30 CONTINUE C C RESET THE RIGHT HAND SIDE IN USOL C DO 60 I=IS,MS DO 50 J=JS,NS USOL(I,J) = GRHS(I,J) 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE MINSO4 (USOL,IDMN,ZN,ZM,PERTB) C C THIS SUBROUTINE ORTHO4ONALIZES THE ARRAY USOL WITH RESPECT TO C THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION USOL(IDMN,1) ,ZN(1) ,ZM(1) C C ENTRY AT MINSO4 OCCURRS WHEN THE FINAL SOLUTION IS C TO BE MINIMIZED WITH RESPECT TO THE WEIGHTED C LEAST SQUARES NORM C ISTR = 1 IFNL = K JSTR = 1 JFNL = L C C COMPUTE WEIGHTED INNER PRODUCTS C UTE = 0.0 ETE = 0.0 DO 20 I=IS,MS II = I-IS+1 DO 10 J=JS,NS JJ = J-JS+1 ETE = ETE+ZM(II)*ZN(JJ) UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) 10 CONTINUE 20 CONTINUE C C SET PERTURBATION PARAMETER C PERTRB = UTE/ETE C C SUBTRACT OFF CONSTANT PERTRB C DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE RETURN END C FISHPAK15 FROM PORTLIB 03/12/81 SUBROUTINE GENBUN (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W) C C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * C * F I S H P A K * C * * C * * C * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * C * * C * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * C * * C * (VERSION 3.1 , OCTOBER 1980) * C * * C * BY * C * * C * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * C * * C * OF * C * * C * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * C * * C * BOULDER, COLORADO (80307) U.S.A. * C * * C * WHICH IS SPONSORED BY * C * * C * THE NATIONAL SCIENCE FOUNDATION * C * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C C * * * * * * * * * PURPOSE * * * * * * * * * * * * * * * * * * C C C SUBROUTINE GENBUN SOLVES THE LINEAR SYSTEM OF EQUATIONS C C A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J) C C + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J) C C FOR I = 1,2,...,M AND J = 1,2,...,N. C C THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M, I.E., C X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND X(I,0) MAY BE EQUAL TO C 0, X(I,2), OR X(I,N) AND X(I,N+1) MAY BE EQUAL TO 0, X(I,N-1), OR C X(I,1) DEPENDING ON AN INPUT PARAMETER. C C C * * * * * * * * PARAMETER DESCRIPTION * * * * * * * * * * C C * * * * * * ON INPUT * * * * * * C C NPEROD C INDICATES THE VALUES THAT X(I,0) AND X(I,N+1) ARE ASSUMED TO C HAVE. C C = 0 IF X(I,0) = X(I,N) AND X(I,N+1) = X(I,1). C = 1 IF X(I,0) = X(I,N+1) = 0 . C = 2 IF X(I,0) = 0 AND X(I,N+1) = X(I,N-1). C = 3 IF X(I,0) = X(I,2) AND X(I,N+1) = X(I,N-1). C = 4 IF X(I,0) = X(I,2) AND X(I,N+1) = 0. C C N C THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. N MUST BE GREATER C THAN 2. C C MPEROD C = 0 IF A(1) AND C(M) ARE NOT ZERO C = 1 IF A(1) = C(M) = 0 C C M C THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. M MUST BE GREATER C THAN 2. C C A,B,C C ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE C COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE. IF MPEROD = 0 C THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE INDEX I, BUT MUST BE C CONSTANT. SPECIFICALLY, THE SUBROUTINE CHECKS THE FOLLOWING C CONDITION C C A(I) = C(1) C C(I) = C(1) C B(I) = B(1) C C FOR I=1,2,...,M. C C IDIMY C THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS C IT APPEARS IN THE PROGRAM CALLING GENBUN. THIS PARAMETER IS C USED TO SPECIFY THE VARIABLE DIMENSION OF Y. IDIMY MUST BE AT C LEAST M. C C Y C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT C SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE. Y MUST BE C DIMENSIONED AT LEAST M*N. C C W C A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR C WORK SPACE. W MAY REQUIRE UP TO 4*N + (10 + INT(LOG2(N)))*M C LOCATIONS. THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY C GENBUN AND IS RETURNED IN LOCATION W(1). C C C * * * * * * ON OUTPUT * * * * * * C C Y C CONTAINS THE SOLUTION X. C C IERROR C AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS EXCEPT C FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED. C C = 0 NO ERROR. C = 1 M .LE. 2 . C = 2 N .LE. 2 C = 3 IDIMY .LT. M C = 4 NPEROD .LT. 0 OR NPEROD .GT. 4 C = 5 MPEROD .LT. 0 OR MPEROD .GT. 1 C = 6 A(I) .NE. C(1) OR C(I) .NE. C(1) OR B(I) .NE. B(1) FOR C SOME I=1,2,...,M. C = 7 A(1) .NE. 0 OR C(M) .NE. 0 AND MPEROD = 1 C C W C W(1) CONTAINS THE REQUIRED LENGTH OF W. C C * * * * * * * PROGRAM SPECIFICATIONS * * * * * * * * * * * * C C DIMENSION OF A(M),B(M),C(M),Y(IDIMY,N),W(SEE PARAMETER LIST) C ARGUMENTS C C LATEST JUNE 1, 1976 C REVISION C C SUBPROGRAMS GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,TRIX,TRI3, C REQUIRED PIMACH C C SPECIAL NONE C CONDITIONS C C COMMON NONE C BLOCKS C C I/O NONE C C PRECISION SINGLE C C SPECIALIST ROLAND SWEET C C LANGUAGE FORTRAN C C HISTORY STANDARDIZED APRIL 1, 1973 C REVISED AUGUST 20,1973 C REVISED JANUARY 1, 1976 C C ALGORITHM THE LINEAR SYSTEM IS SOLVED BY A CYCLIC REDUCTION C ALGORITHM DESCRIBED IN THE REFERENCE. C C SPACE 4944(DECIMAL) = 11520(OCTAL) LOCATIONS ON THE NCAR C REQUIRED CONTROL DATA 7600 C C TIMING AND THE EXECUTION TIME T ON THE NCAR CONTROL DATA C ACCURACY 7600 FOR SUBROUTINE GENBUN IS ROUGHLY PROPORTIONAL C TO M*N*LOG2(N), BUT ALSO DEPENDS ON THE INPUT C PARAMETER NPEROD. SOME TYPICAL VALUES ARE LISTED C IN THE TABLE BELOW. MORE COMPREHENSIVE TIMING C CHARTS MAY BE FOUND IN THE REFERENCE. C TO MEASURE THE ACCURACY OF THE ALGORITHM A C UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE C A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE C "PURPOSE" WITH C C A(I) = C(I) = -0.5*B(I) = 1, I=1,2,...,M C C AND, WHEN MPEROD = 1 C C A(1) = C(M) = 0 C A(M) = C(1) = 2. C C THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS- C TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS C COMPUTED. USING THIS ARRAY Y SUBROUTINE GENBUN WAS C CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z. THEN C THE RELATIVE ERROR, DEFINED AS C C E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J))) C C WHERE THE TWO MAXIMA ARE TAKEN OVER ALL I=1,2,...,M C AND J=1,2,...,N, WAS COMPUTED. THE VALUE OF E IS C GIVEN IN THE TABLE BELOW FOR SOME TYPICAL VALUES OF C M AND N. C C C M (=N) MPEROD NPEROD T(MSECS) E C ------ ------ ------ -------- ------ C C 31 0 0 36 6.E-14 C 31 1 1 21 4.E-13 C 31 1 3 41 3.E-13 C 32 0 0 29 9.E-14 C 32 1 1 32 3.E-13 C 32 1 3 48 1.E-13 C 33 0 0 36 9.E-14 C 33 1 1 30 4.E-13 C 33 1 3 34 1.E-13 C 63 0 0 150 1.E-13 C 63 1 1 91 1.E-12 C 63 1 3 173 2.E-13 C 64 0 0 122 1.E-13 C 64 1 1 128 1.E-12 C 64 1 3 199 6.E-13 C 65 0 0 143 2.E-13 C 65 1 1 120 1.E-12 C 65 1 3 138 4.E-13 C C PORTABILITY AMERICAN NATIONAL STANDARDS INSTITUE FORTRAN. C ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE C FUNCTION PIMACH. C C REQUIRED COS C RESIDENT C ROUTINES C C REFERENCE SWEET, R., "A CYCLIC REDUCTION ALGORITHM FOR C SOLVING BLOCK TRIDIAGONAL SYSTEMS OF ARBITRARY C DIMENSIONS," SIAM J. ON NUMER. ANAL., C 14(SEPT., 1977), PP. 706-720. C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C DIMENSION Y(IDIMY,1) DIMENSION W(1) ,B(1) ,A(1) ,C(1) IERROR = 0 IF (M .LE. 2) IERROR = 1 IF (N .LE. 2) IERROR = 2 IF (IDIMY .LT. M) IERROR = 3 IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4 IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5 IF (MPEROD .EQ. 1) GO TO 102 DO 101 I=2,M IF (A(I) .NE. C(1)) GO TO 103 IF (C(I) .NE. C(1)) GO TO 103 IF (B(I) .NE. B(1)) GO TO 103 101 CONTINUE GO TO 104 102 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7 GO TO 104 103 IERROR = 6 104 IF (IERROR .NE. 0) RETURN MP1 = M+1 IWBA = MP1 IWBB = IWBA+M IWBC = IWBB+M IWB2 = IWBC+M IWB3 = IWB2+M IWW1 = IWB3+M IWW2 = IWW1+M IWW3 = IWW2+M IWD = IWW3+M IWTCOS = IWD+M IWP = IWTCOS+4*N DO 106 I=1,M K = IWBA+I-1 W(K) = -A(I) K = IWBC+I-1 W(K) = -C(I) K = IWBB+I-1 W(K) = 2.-B(I) DO 105 J=1,N Y(I,J) = -Y(I,J) 105 CONTINUE 106 CONTINUE MP = MPEROD+1 NP = NPEROD+1 GO TO (114,107),MP 107 GO TO (108,109,110,111,123),NP 108 CALL POISP2 (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), 2 W(IWP)) GO TO 112 109 CALL POISD2 (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1), 1 W(IWD),W(IWTCOS),W(IWP)) GO TO 112 110 CALL POISN2 (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), 2 W(IWP)) GO TO 112 111 CALL POISN2 (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2), 1 W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS), 2 W(IWP)) 112 IPSTOR = W(IWW1) IREV = 2 IF (NPEROD .EQ. 4) GO TO 124 113 GO TO (127,133),MP 114 CONTINUE C C REORDER UNKNOWNS WHEN MP =0 C MH = (M+1)/2 MHM1 = MH-1 MODD = 1 IF (MH*2 .EQ. M) MODD = 2 DO 119 J=1,N DO 115 I=1,MHM1 MHPI = MH+I MHMI = MH-I W(I) = Y(MHMI,J)-Y(MHPI,J) W(MHPI) = Y(MHMI,J)+Y(MHPI,J) 115 CONTINUE W(MH) = 2.*Y(MH,J) GO TO (117,116),MODD 116 W(M) = 2.*Y(M,J) 117 CONTINUE DO 118 I=1,M Y(I,J) = W(I) 118 CONTINUE 119 CONTINUE K = IWBC+MHM1-1 I = IWBA+MHM1 W(K) = 0. W(I) = 0. W(K+1) = 2.*W(K+1) GO TO (120,121),MODD 120 CONTINUE K = IWBB+MHM1-1 W(K) = W(K)-W(I-1) W(IWBC-1) = W(IWBC-1)+W(IWBB-1) GO TO 122 121 W(IWBB-1) = W(K+1) 122 CONTINUE GO TO 107 C C REVERSE COLUMNS WHEN NPEROD = 4. C 123 IREV = 1 NBY2 = N/2 124 DO 126 J=1,NBY2 MSKIP = N+1-J DO 125 I=1,M A1 = Y(I,J) Y(I,J) = Y(I,MSKIP) Y(I,MSKIP) = A1 125 CONTINUE 126 CONTINUE GO TO (110,113),IREV 127 CONTINUE DO 132 J=1,N DO 128 I=1,MHM1 MHMI = MH-I MHPI = MH+I W(MHMI) = .5*(Y(MHPI,J)+Y(I,J)) W(MHPI) = .5*(Y(MHPI,J)-Y(I,J)) 128 CONTINUE W(MH) = .5*Y(MH,J) GO TO (130,129),MODD 129 W(M) = .5*Y(M,J) 130 CONTINUE DO 131 I=1,M Y(I,J) = W(I) 131 CONTINUE 132 CONTINUE 133 CONTINUE C C RETURN STORAGE REQUIREMENTS FOR W ARRAY. C W(1) = IPSTOR+IWP-1 RETURN END SUBROUTINE CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR) C C THIS SUBROUTINE CHECKS IF THE PDE SEPX4 C MUST SOLVE IS A SINGULAR OPERATOR C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 LOGICAL SINGLR EXTERNAL COFX SINGLR = .FALSE. C C CHECK IF THE BOUNDARY CONDITIONS ARE C ENTIRELY PERIODIC AND/OR MIXED C IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR. 1 (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN C C CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN C IF (MBDCND .NE. 3) GO TO 10 IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN 10 CONTINUE C C CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS C ARE ZERO C DO 30 I=IS,MS XI = AIT+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) IF (CI .NE. 0.0) RETURN 30 CONTINUE C C THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED C SINGLR = .TRUE. RETURN END SUBROUTINE POISP2 (M,N,A,BB,C,Q,IDIMQ,B,B2,B3,W,W2,W3,D,TCOS,P) C C SUBROUTINE TO SOLVE POISSON EQUATION WITH PERIODIC BOUNDARY C CONDITIONS. C DIMENSION A(1) ,BB(1) ,C(1) ,Q(IDIMQ,1) , 1 B(1) ,B2(1) ,B3(1) ,W(1) , 2 W2(1) ,W3(1) ,D(1) ,TCOS(1) , 3 P(1) MR = M NR = (N+1)/2 NRM1 = NR-1 IF (2*NR .NE. N) GO TO 107 C C EVEN NUMBER OF UNKNOWNS C DO 102 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 101 I=1,MR S = Q(I,NRMJ)-Q(I,NRPJ) T = Q(I,NRMJ)+Q(I,NRPJ) Q(I,NRMJ) = S Q(I,NRPJ) = T 101 CONTINUE 102 CONTINUE DO 103 I=1,MR Q(I,NR) = 2.*Q(I,NR) Q(I,N) = 2.*Q(I,N) 103 CONTINUE CALL POISD2 (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = W(1) CALL POISN2 (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, 1 TCOS,P) IPSTOR = MAX0(IPSTOR,INT(W(1))) DO 105 J=1,NRM1 NRMJ = NR-J NRPJ = NR+J DO 104 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,NRMJ)) T = .5*(Q(I,NRPJ)-Q(I,NRMJ)) Q(I,NRMJ) = S Q(I,NRPJ) = T 104 CONTINUE 105 CONTINUE DO 106 I=1,MR Q(I,NR) = .5*Q(I,NR) Q(I,N) = .5*Q(I,N) 106 CONTINUE GO TO 118 107 CONTINUE C C ODD NUMBER OF UNKNOWNS C DO 109 J=1,NRM1 NRPJ = N+1-J DO 108 I=1,MR S = Q(I,J)-Q(I,NRPJ) T = Q(I,J)+Q(I,NRPJ) Q(I,J) = S Q(I,NRPJ) = T 108 CONTINUE 109 CONTINUE DO 110 I=1,MR Q(I,NR) = 2.*Q(I,NR) 110 CONTINUE LH = NRM1/2 DO 112 J=1,LH NRMJ = NR-J DO 111 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 111 CONTINUE 112 CONTINUE CALL POISD2 (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P) IPSTOR = W(1) CALL POISN2 (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D, 1 TCOS,P) IPSTOR = MAX0(IPSTOR,INT(W(1))) DO 114 J=1,NRM1 NRPJ = NR+J DO 113 I=1,MR S = .5*(Q(I,NRPJ)+Q(I,J)) T = .5*(Q(I,NRPJ)-Q(I,J)) Q(I,NRPJ) = T Q(I,J) = S 113 CONTINUE 114 CONTINUE DO 115 I=1,MR Q(I,NR) = .5*Q(I,NR) 115 CONTINUE DO 117 J=1,LH NRMJ = NR-J DO 116 I=1,MR S = Q(I,J) Q(I,J) = Q(I,NRMJ) Q(I,NRMJ) = S 116 CONTINUE 117 CONTINUE 118 CONTINUE C C RETURN STORAGE REQUIREMENTS FOR P VECTORS. C W(1) = IPSTOR RETURN END SUBROUTINE POISN2 (M,N,ISTAG,MIXBND,A,BB,C,Q,IDIMQ,B,B2,B3,W,W2, 1 W3,D,TCOS,P) C C SUBROUTINE TO SOLVE POISSON"S EQUATION WITH NEUMANN BOUNDARY C CONDITIONS. C C ISTAG = 1 IF THE LAST DIAGONAL BLOCK IS A. C ISTAG = 2 IF THE LAST DIAGONAL BLOCK IS A-I. C MIXBND = 1 IF HAVE NEUMANN BOUNDARY CONDITIONS AT BOTH BOUNDARIES. C MIXBND = 2 IF HAVE NEUMANN BOUNDARY CONDITIONS AT BOTTOM AND C DIRICHLET CONDITION AT TOP. (FOR THIS CASE, MUST HAVE ISTAG = 1.) C DIMENSION A(1) ,BB(1) ,C(1) ,Q(IDIMQ,1) , 1 B(1) ,B2(1) ,B3(1) ,W(1) , 2 W2(1) ,W3(1) ,D(1) ,TCOS(1) , 3 K(4) ,P(1) EQUIVALENCE (K(1),K1) ,(K(2),K2) ,(K(3),K3) ,(K(4),K4) FISTAG = 3-ISTAG FNUM = 1./FLOAT(ISTAG) FDEN = 0.5*FLOAT(ISTAG-1) MR = M IP = -MR IPSTOR = 0 I2R = 1 JR = 2 NR = N NLAST = N KR = 1 LR = 0 GO TO (101,103),ISTAG 101 CONTINUE DO 102 I=1,MR Q(I,N) = .5*Q(I,N) 102 CONTINUE GO TO (103,104),MIXBND 103 IF (N .LE. 3) GO TO 155 104 CONTINUE JR = 2*I2R NROD = 1 IF ((NR/2)*2 .EQ. NR) NROD = 0 GO TO (105,106),MIXBND 105 JSTART = 1 GO TO 107 106 JSTART = JR NROD = 1-NROD 107 CONTINUE JSTOP = NLAST-JR IF (NROD .EQ. 0) JSTOP = JSTOP-I2R CALL COSGEN (I2R,1,0.5,0.0,TCOS) I2RBY2 = I2R/2 IF (JSTOP .GE. JSTART) GO TO 108 J = JR GO TO 116 108 CONTINUE C C REGULAR REDUCTION. C DO 115 J=JSTART,JSTOP,JR JP1 = J+I2RBY2 JP2 = J+I2R JP3 = JP2+I2RBY2 JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 IF (J .NE. 1) GO TO 109 JM1 = JP1 JM2 = JP2 JM3 = JP3 109 CONTINUE IF (I2R .NE. 1) GO TO 111 IF (J .EQ. 1) JM2 = JP2 DO 110 I=1,MR B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 110 CONTINUE GO TO 113 111 CONTINUE DO 112 I=1,MR FI = Q(I,J) Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3) 112 CONTINUE 113 CONTINUE CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) DO 114 I=1,MR Q(I,J) = Q(I,J)+B(I) 114 CONTINUE C C END OF REDUCTION FOR REGULAR UNKNOWNS. C 115 CONTINUE C C BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN. C J = JSTOP+JR 116 NLAST = J JM1 = J-I2RBY2 JM2 = J-I2R JM3 = JM2-I2RBY2 IF (NROD .EQ. 0) GO TO 128 C C ODD NUMBER OF UNKNOWNS C IF (I2R .NE. 1) GO TO 118 DO 117 I=1,MR B(I) = FISTAG*Q(I,J) Q(I,J) = Q(I,JM2) 117 CONTINUE GO TO 126 118 DO 119 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 119 CONTINUE IF (NRODPR .NE. 0) GO TO 121 DO 120 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II) 120 CONTINUE IP = IP-MR GO TO 123 121 CONTINUE DO 122 I=1,MR Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2) 122 CONTINUE 123 IF (LR .EQ. 0) GO TO 124 CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) GO TO 126 124 CONTINUE DO 125 I=1,MR B(I) = FISTAG*B(I) 125 CONTINUE 126 CONTINUE CALL COSGEN (KR,1,0.5,FDEN,TCOS) CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 127 I=1,MR Q(I,J) = Q(I,J)+B(I) 127 CONTINUE KR = KR+I2R GO TO 151 128 CONTINUE C C EVEN NUMBER OF UNKNOWNS C JP1 = J+I2RBY2 JP2 = J+I2R IF (I2R .NE. 1) GO TO 135 DO 129 I=1,MR B(I) = Q(I,J) 129 CONTINUE CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) IP = 0 IPSTOR = MR GO TO (133,130),ISTAG 130 DO 131 I=1,MR P(I) = B(I) B(I) = B(I)+Q(I,N) 131 CONTINUE TCOS(1) = 1. TCOS(2) = 0. CALL TRIX (1,1,MR,A,BB,C,B,TCOS,D,W) DO 132 I=1,MR Q(I,J) = Q(I,JM2)+P(I)+B(I) 132 CONTINUE GO TO 150 133 CONTINUE DO 134 I=1,MR P(I) = B(I) Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I) 134 CONTINUE GO TO 150 135 CONTINUE DO 136 I=1,MR B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 136 CONTINUE IF (NRODPR .NE. 0) GO TO 138 DO 137 I=1,MR II = IP+I B(I) = B(I)+P(II) 137 CONTINUE GO TO 140 138 CONTINUE DO 139 I=1,MR B(I) = B(I)+Q(I,JP2)-Q(I,JP1) 139 CONTINUE 140 CONTINUE CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W) IP = IP+MR IPSTOR = MAX0(IPSTOR,IP+MR) DO 141 I=1,MR II = IP+I P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) B(I) = P(II)+Q(I,JP2) 141 CONTINUE IF (LR .EQ. 0) GO TO 142 CALL COSGEN (LR,1,0.5,FDEN,TCOS(I2R+1)) CALL MERGE (TCOS,0,I2R,I2R,LR,KR) GO TO 144 142 DO 143 I=1,I2R II = KR+I TCOS(II) = TCOS(I) 143 CONTINUE 144 CALL COSGEN (KR,1,0.5,FDEN,TCOS) IF (LR .NE. 0) GO TO 145 GO TO (146,145),ISTAG 145 CONTINUE CALL TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W) GO TO 148 146 CONTINUE DO 147 I=1,MR B(I) = FISTAG*B(I) 147 CONTINUE 148 CONTINUE DO 149 I=1,MR II = IP+I Q(I,J) = Q(I,JM2)+P(II)+B(I) 149 CONTINUE 150 CONTINUE LR = KR KR = KR+JR 151 CONTINUE GO TO (152,153),MIXBND 152 NR = (NLAST-1)/JR+1 IF (NR .LE. 3) GO TO 155 GO TO 154 153 NR = NLAST/JR IF (NR .LE. 1) GO TO 192 154 I2R = JR NRODPR = NROD GO TO 104 155 CONTINUE C C BEGIN SOLUTION C J = 1+JR JM1 = J-I2R JP1 = J+I2R JM2 = NLAST-I2R IF (NR .EQ. 2) GO TO 184 IF (LR .NE. 0) GO TO 170 IF (N .NE. 3) GO TO 161 C C CASE N = 3. C GO TO (156,168),ISTAG 156 CONTINUE DO 157 I=1,MR B(I) = Q(I,2) 157 CONTINUE TCOS(1) = 0. CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 158 I=1,MR Q(I,2) = B(I) B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3) 158 CONTINUE TCOS(1) = -2. TCOS(2) = 2. I1 = 2 I2 = 0 CALL TRIX (I1,I2,MR,A,BB,C,B,TCOS,D,W) DO 159 I=1,MR Q(I,2) = Q(I,2)+B(I) B(I) = Q(I,1)+2.*Q(I,2) 159 CONTINUE TCOS(1) = 0. CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 160 I=1,MR Q(I,1) = B(I) 160 CONTINUE JR = 1 I2R = 0 GO TO 194 C C CASE N = 2**P+1 C 161 CONTINUE GO TO (162,170),ISTAG 162 CONTINUE DO 163 I=1,MR B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2) 163 CONTINUE CALL COSGEN (JR,1,0.5,0.0,TCOS) CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 164 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J) 164 CONTINUE JR2 = 2*JR CALL COSGEN (JR,1,0.0,0.0,TCOS) DO 165 I=1,JR I1 = JR+I I2 = JR+1-I TCOS(I1) = -TCOS(I2) 165 CONTINUE CALL TRIX (JR2,0,MR,A,BB,C,B,TCOS,D,W) DO 166 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 166 CONTINUE CALL COSGEN (JR,1,0.5,0.0,TCOS) CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 167 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 167 CONTINUE GO TO 194 C C CASE OF GENERAL N WITH NR = 3 . C 168 DO 169 I=1,MR B(I) = Q(I,2) Q(I,2) = 0. B2(I) = Q(I,3) B3(I) = Q(I,1) 169 CONTINUE JR = 1 I2R = 0 J = 2 GO TO 177 170 CONTINUE DO 171 I=1,MR B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J) 171 CONTINUE IF (NROD .NE. 0) GO TO 173 DO 172 I=1,MR II = IP+I B(I) = B(I)+P(II) 172 CONTINUE GO TO 175 173 DO 174 I=1,MR B(I) = B(I)+Q(I,NLAST)-Q(I,JM2) 174 CONTINUE 175 CONTINUE DO 176 I=1,MR T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) Q(I,J) = T B2(I) = Q(I,NLAST)+T B3(I) = Q(I,1)+2.*T 176 CONTINUE 177 CONTINUE K1 = KR+2*JR-1 K2 = KR+JR TCOS(K1+1) = -2. K4 = K1+3-ISTAG CALL COSGEN (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+K2+1 CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) CALL MERGE (TCOS,K1,K2,K1+K2,JR-1,0) K3 = K1+K2+LR CALL COSGEN (JR,1,0.5,0.0,TCOS(K3+1)) K4 = K3+JR+1 CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4)) CALL MERGE (TCOS,K3,JR,K3+JR,KR,K1) IF (LR .EQ. 0) GO TO 178 CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4)) CALL MERGE (TCOS,K3,JR,K3+JR,LR,K3-LR) CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4)) 178 K3 = KR K4 = KR CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 179 I=1,MR B(I) = B(I)+B2(I)+B3(I) 179 CONTINUE TCOS(1) = 2. CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 180 I=1,MR Q(I,J) = Q(I,J)+B(I) B(I) = Q(I,1)+2.*Q(I,J) 180 CONTINUE CALL COSGEN (JR,1,0.5,0.0,TCOS) CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) IF (JR .NE. 1) GO TO 182 DO 181 I=1,MR Q(I,1) = B(I) 181 CONTINUE GO TO 194 182 CONTINUE DO 183 I=1,MR Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I) 183 CONTINUE GO TO 194 184 CONTINUE IF (N .NE. 2) GO TO 188 C C CASE N = 2 C DO 185 I=1,MR B(I) = Q(I,1) 185 CONTINUE TCOS(1) = 0. CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 186 I=1,MR Q(I,1) = B(I) B(I) = 2.*(Q(I,2)+B(I))*FISTAG 186 CONTINUE TCOS(1) = -FISTAG TCOS(2) = 2. CALL TRIX (2,0,MR,A,BB,C,B,TCOS,D,W) DO 187 I=1,MR Q(I,1) = Q(I,1)+B(I) 187 CONTINUE JR = 1 I2R = 0 GO TO 194 188 CONTINUE C C CASE OF GENERAL N AND NR = 2 . C DO 189 I=1,MR II = IP+I B3(I) = 0. B(I) = Q(I,1)+2.*P(II) Q(I,1) = .5*Q(I,1)-Q(I,JM1) B2(I) = 2.*(Q(I,1)+Q(I,NLAST)) 189 CONTINUE K1 = KR+JR-1 TCOS(K1+1) = -2. K4 = K1+3-ISTAG CALL COSGEN (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4)) K4 = K1+KR+1 CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4)) CALL MERGE (TCOS,K1,KR,K1+KR,JR-1,0) CALL COSGEN (KR,1,0.5,FDEN,TCOS(K1+1)) K2 = KR K4 = K1+K2+1 CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4)) K3 = LR K4 = 0 CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3) DO 190 I=1,MR B(I) = B(I)+B2(I) 190 CONTINUE TCOS(1) = 2. CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W) DO 191 I=1,MR Q(I,1) = Q(I,1)+B(I) 191 CONTINUE GO TO 194 192 DO 193 I=1,MR B(I) = Q(I,NLAST) 193 CONTINUE GO TO 196 194 CONTINUE C C START BACK SUBSTITUTION. C J = NLAST-JR DO 195 I=1,MR B(I) = Q(I,NLAST)+Q(I,J) 195 CONTINUE 196 JM2 = NLAST-I2R IF (JR .NE. 1) GO TO 198 DO 197 I=1,MR Q(I,NLAST) = 0. 197 CONTINUE GO TO 202 198 CONTINUE IF (NROD .NE. 0) GO TO 200 DO 199 I=1,MR II = IP+I Q(I,NLAST) = P(II) 199 CONTINUE IP = IP-MR GO TO 202 200 DO 201 I=1,MR Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2) 201 CONTINUE 202 CONTINUE CALL COSGEN (KR,1,0.5,FDEN,TCOS) CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1)) IF (LR .NE. 0) GO TO 204 DO 203 I=1,MR B(I) = FISTAG*B(I) 203 CONTINUE 204 CONTINUE CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W) DO 205 I=1,MR Q(I,NLAST) = Q(I,NLAST)+B(I) 205 CONTINUE NLASTP = NLAST 206 CONTINUE JSTEP = JR JR = I2R I2R = I2R/2 IF (JR .EQ. 0) GO TO 222 GO TO (207,208),MIXBND 207 JSTART = 1+JR GO TO 209 208 JSTART = JR 209 CONTINUE KR = KR-JR IF (NLAST+JR .GT. N) GO TO 210 KR = KR-JR NLAST = NLAST+JR JSTOP = NLAST-JSTEP GO TO 211 210 CONTINUE JSTOP = NLAST-JR 211 CONTINUE LR = KR-JR CALL COSGEN (JR,1,0.5,0.0,TCOS) DO 221 J=JSTART,JSTOP,JSTEP JM2 = J-JR JP2 = J+JR IF (J .NE. JR) GO TO 213 DO 212 I=1,MR B(I) = Q(I,J)+Q(I,JP2) 212 CONTINUE GO TO 215 213 CONTINUE DO 214 I=1,MR B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 214 CONTINUE 215 CONTINUE IF (JR .NE. 1) GO TO 217 DO 216 I=1,MR Q(I,J) = 0. 216 CONTINUE GO TO 219 217 CONTINUE JM1 = J-I2R JP1 = J+I2R DO 218 I=1,MR Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 218 CONTINUE 219 CONTINUE CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W) DO 220 I=1,MR Q(I,J) = Q(I,J)+B(I) 220 CONTINUE 221 CONTINUE NROD = 1 IF (NLAST+I2R .LE. N) NROD = 0 IF (NLASTP .NE. NLAST) GO TO 194 GO TO 206 222 CONTINUE C C RETURN STORAGE REQUIREMENTS FOR P VECTORS. C W(1) = IPSTOR RETURN END SUBROUTINE TRIX (IDEGBR,IDEGCR,M,A,B,C,Y,TCOS,D,W) C C SUBROUTINE TO SOLVE A SYSTEM OF LINEAR EQUATIONS WHERE THE C COEFFICIENT MATRIX IS A RATIONAL FUNCTION IN THE MATRIX GIVEN BY C TRIDIAGONAL ( . . . , A(I), B(I), C(I), . . . ). C DIMENSION A(1) ,B(1) ,C(1) ,Y(1) , 1 TCOS(1) ,D(1) ,W(1) MM1 = M-1 FB = IDEGBR+1 FC = IDEGCR+1 L = FB/FC LINT = 1 DO 108 K=1,IDEGBR X = TCOS(K) IF (K .NE. L) GO TO 102 I = IDEGBR+LINT XX = X-TCOS(I) DO 101 I=1,M W(I) = Y(I) Y(I) = XX*Y(I) 101 CONTINUE 102 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y(1) = Y(1)*Z DO 103 I=2,MM1 Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y(I) = (Y(I)-A(I)*Y(I-1))*Z 103 CONTINUE Z = B(M)-X-A(M)*D(MM1) IF (Z .NE. 0.) GO TO 104 Y(M) = 0. GO TO 105 104 Y(M) = (Y(M)-A(M)*Y(MM1))/Z 105 CONTINUE DO 106 IP=1,MM1 I = M-IP Y(I) = Y(I)-D(I)*Y(I+1) 106 CONTINUE IF (K .NE. L) GO TO 108 DO 107 I=1,M Y(I) = Y(I)+W(I) 107 CONTINUE LINT = LINT+1 L = (FLOAT(LINT)*FB)/FC 108 CONTINUE RETURN END C FISHPAK23 FROM PORTLIB 03/12/81 C C C THIS FILE CONTAINS FOUR SUBROUTINES USED BY SUBROUTINES GENBUN C (FILE 15) AND POISTG (FILE 17). C C SUBROUTINE COSGEN (N,IJUMP,FNUM,FDEN,A) DIMENSION A(1) C C C THIS SUBROUTINE COMPUTES REQUIRED COSINE VALUES IN ASCENDING C ORDER. WHEN IJUMP .GT. 1 THE ROUTINE COMPUTES VALUES C C 2*COS(J*PI/L) , J=1,2,...,L AND J .NE. 0(MOD N/IJUMP+1) C C WHERE L = IJUMP*(N/IJUMP+1). C C C WHEN IJUMP = 1 IT COMPUTES C C 2*COS((J-FNUM)*PI/(N+FDEN)) , J=1, 2, ... ,N C C WHERE C FNUM = 0.5, FDEN = 0.0, FOR REGULAR REDUCTION VALUES C FNUM = 0.0, FDEN = 1.0, FOR B-R AND C-R WHEN ISTAG = 1 C FNUM = 0.0, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2 C FNUM = 0.5, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2 C IN POISN2 ONLY. C C PI = PIMACH(DUM) IF (N .EQ. 0) GO TO 105 IF (IJUMP .EQ. 1) GO TO 103 K3 = N/IJUMP+1 K4 = K3-1 PIBYN = PI/FLOAT(N+IJUMP) DO 102 K=1,IJUMP K1 = (K-1)*K3 K5 = (K-1)*K4 DO 101 I=1,K4 X = K1+I K2 = K5+I A(K2) = -2.*COS(X*PIBYN) 101 CONTINUE 102 CONTINUE GO TO 105 103 CONTINUE NP1 = N+1 Y = PI/(FLOAT(N)+FDEN) DO 104 I=1,N X = FLOAT(NP1-I)-FNUM A(I) = 2.*COS(X*Y) 104 CONTINUE 105 CONTINUE RETURN END SUBROUTINE DX4(U,IDMN,I,J,UXXX,UXXXX) C C THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE C APPROXIMATIONS TO THE THIRD AND FOURTH X C PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,1) IF (I.GT.2 .AND. I.LT.(K-1)) GO TO 50 IF (I .EQ. 1) GO TO 10 IF (I .EQ. 2) GO TO 30 IF (I .EQ. K-1) GO TO 60 IF (I .EQ. K) GO TO 80 C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A C 10 IF (KSWX .EQ. 1) GO TO 20 UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)- 1 3.0*U(5,J))/(TDLX3) UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+ 1 11.0*U(5,J)-2.0*U(6,J))/DLX4 RETURN C C PERIODIC AT X=A C 20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3) UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX C 30 IF (KSWX .EQ. 1) GO TO 40 UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/ 1 TDLX3 UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)- 1 U(6,J))/DLX4 RETURN C C PERIODIC AT X=A+DLX C 40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3) UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR C 50 CONTINUE UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3 UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/ 1 DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX C 60 IF (KSWX .EQ. 1) GO TO 70 UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+ 1 3.0*U(K,J))/TDLX3 UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)- 1 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 RETURN C C PERIODIC AT X=B-DLX C 70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3 UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/ 1 DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B C 80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+ 1 5.0*U(K,J))/TDLX3 UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)- 1 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 RETURN END SUBROUTINE TRI3 (M,A,B,C,K,Y1,Y2,Y3,TCOS,D,W1,W2,W3) DIMENSION A(1) ,B(1) ,C(1) ,K(4) , 1 TCOS(1) ,Y1(1) ,Y2(1) ,Y3(1) , 2 D(1) ,W1(1) ,W2(1) ,W3(1) C C SUBROUTINE TO SOLVE THREE LINEAR SYSTEMS WHOSE COMMON COEFFICIENT C MATRIX IS A RATIONAL FUNCTION IN THE MATRIX GIVEN BY C C TRIDIAGONAL (...,A(I),B(I),C(I),...) C MM1 = M-1 K1 = K(1) K2 = K(2) K3 = K(3) K4 = K(4) F1 = K1+1 F2 = K2+1 F3 = K3+1 F4 = K4+1 K2K3K4 = K2+K3+K4 IF (K2K3K4 .EQ. 0) GO TO 101 L1 = F1/F2 L2 = F1/F3 L3 = F1/F4 LINT1 = 1 LINT2 = 1 LINT3 = 1 KINT1 = K1 KINT2 = KINT1+K2 KINT3 = KINT2+K3 101 CONTINUE DO 115 N=1,K1 X = TCOS(N) IF (K2K3K4 .EQ. 0) GO TO 107 IF (N .NE. L1) GO TO 103 DO 102 I=1,M W1(I) = Y1(I) 102 CONTINUE 103 IF (N .NE. L2) GO TO 105 DO 104 I=1,M W2(I) = Y2(I) 104 CONTINUE 105 IF (N .NE. L3) GO TO 107 DO 106 I=1,M W3(I) = Y3(I) 106 CONTINUE 107 CONTINUE Z = 1./(B(1)-X) D(1) = C(1)*Z Y1(1) = Y1(1)*Z Y2(1) = Y2(1)*Z Y3(1) = Y3(1)*Z DO 108 I=2,M Z = 1./(B(I)-X-A(I)*D(I-1)) D(I) = C(I)*Z Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z 108 CONTINUE DO 109 IP=1,MM1 I = M-IP Y1(I) = Y1(I)-D(I)*Y1(I+1) Y2(I) = Y2(I)-D(I)*Y2(I+1) Y3(I) = Y3(I)-D(I)*Y3(I+1) 109 CONTINUE IF (K2K3K4 .EQ. 0) GO TO 115 IF (N .NE. L1) GO TO 111 I = LINT1+KINT1 XX = X-TCOS(I) DO 110 I=1,M Y1(I) = XX*Y1(I)+W1(I) 110 CONTINUE LINT1 = LINT1+1 L1 = (FLOAT(LINT1)*F1)/F2 111 IF (N .NE. L2) GO TO 113 I = LINT2+KINT2 XX = X-TCOS(I) DO 112 I=1,M Y2(I) = XX*Y2(I)+W2(I) 112 CONTINUE LINT2 = LINT2+1 L2 = (FLOAT(LINT2)*F1)/F3 113 IF (N .NE. L3) GO TO 115 I = LINT3+KINT3 XX = X-TCOS(I) DO 114 I=1,M Y3(I) = XX*Y3(I)+W3(I) 114 CONTINUE LINT3 = LINT3+1 L3 = (FLOAT(LINT3)*F1)/F4 115 CONTINUE RETURN END SUBROUTINE MERGE (TCOS,I1,M1,I2,M2,I3) DIMENSION TCOS(1) C C C THIS SUBROUTINE MERGES TWO ASCENDING STRINGS OF NUMBERS IN THE C ARRAY TCOS. THE FIRST STRING IS OF LENGTH M1 AND STARTS AT C TCOS(I1+1). THE SECOND STRING IS OF LENGTH M2 AND STARTS AT C TCOS(I2+1). THE MERGED STRING GOES INTO TCOS(I3+1). C C J1 = 1 J2 = 1 J = I3 IF (M1 .EQ. 0) GO TO 107 IF (M2 .EQ. 0) GO TO 104 101 J = J+1 L = J1+I1 X = TCOS(L) L = J2+I2 Y = TCOS(L) IF (X-Y) 102,102,103 102 TCOS(J) = X J1 = J1+1 IF (J1 .GT. M1) GO TO 106 GO TO 101 103 TCOS(J) = Y J2 = J2+1 IF (J2 .LE. M2) GO TO 101 IF (J1 .GT. M1) GO TO 109 104 K = J-J1+1 DO 105 J=J1,M1 M = K+J L = J+I1 TCOS(M) = TCOS(L) 105 CONTINUE GO TO 109 106 CONTINUE IF (J2 .GT. M2) GO TO 109 107 K = J-J2+1 DO 108 J=J2,M2 M = K+J L = J+I2 TCOS(M) = TCOS(L) 108 CONTINUE 109 CONTINUE RETURN END SUBROUTINE POISD2 (MR,NR,ISTAG,BA,BB,BC,Q,IDIMQ,B,W,D,TCOS,P) C C SUBROUTINE TO SOLVE POISSON"S EQUATION FOR DIRICHLET BOUNDARY C CONDITIONS. C C ISTAG = 1 IF THE LAST DIAGONAL BLOCK IS THE MATRIX A. C ISTAG = 2 IF THE LAST DIAGONAL BLOCK IS THE MATRIX A+I. C DIMENSION Q(IDIMQ,1) ,BA(1) ,BB(1) ,BC(1) , 1 TCOS(1) ,B(1) ,D(1) ,W(1) , 2 P(1) M = MR N = NR JSH = 0 FI = 1./FLOAT(ISTAG) IP = -M IPSTOR = 0 GO TO (101,102),ISTAG 101 KR = 0 IRREG = 1 IF (N .GT. 1) GO TO 106 TCOS(1) = 0. GO TO 103 102 KR = 1 JSTSAV = 1 IRREG = 2 IF (N .GT. 1) GO TO 106 TCOS(1) = -1. 103 DO 104 I=1,M B(I) = Q(I,1) 104 CONTINUE CALL TRIX (1,0,M,BA,BB,BC,B,TCOS,D,W) DO 105 I=1,M Q(I,1) = B(I) 105 CONTINUE GO TO 183 106 LR = 0 DO 107 I=1,M P(I) = 0. 107 CONTINUE NUN = N JST = 1 JSP = N C C IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2. C 108 L = 2*JST NODD = 2-2*((NUN+1)/2)+NUN C C NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2. C GO TO (110,109),NODD 109 JSP = JSP-L GO TO 111 110 JSP = JSP-JST IF (IRREG .NE. 1) JSP = JSP-L 111 CONTINUE C C REGULAR REDUCTION C CALL COSGEN (JST,1,0.5,0.0,TCOS) IF (L .GT. JSP) GO TO 118 DO 117 J=L,JSP,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH JP3 = JP2+JSH IF (JST .NE. 1) GO TO 113 DO 112 I=1,M B(I) = 2.*Q(I,J) Q(I,J) = Q(I,JM2)+Q(I,JP2) 112 CONTINUE GO TO 115 113 DO 114 I=1,M T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2) B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3) Q(I,J) = T 114 CONTINUE 115 CONTINUE CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) DO 116 I=1,M Q(I,J) = Q(I,J)+B(I) 116 CONTINUE 117 CONTINUE C C REDUCTION FOR LAST UNKNOWN C 118 GO TO (119,136),NODD 119 GO TO (152,120),IRREG C C ODD NUMBER OF UNKNOWNS C 120 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH GO TO (123,121),ISTAG 121 CONTINUE IF (JST .NE. 1) GO TO 123 DO 122 I=1,M B(I) = Q(I,J) Q(I,J) = 0. 122 CONTINUE GO TO 130 123 GO TO (124,126),NODDPR 124 DO 125 I=1,M IP1 = IP+I B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J) 125 CONTINUE GO TO 128 126 DO 127 I=1,M B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J) 127 CONTINUE 128 DO 129 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 129 CONTINUE 130 CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W) IP = IP+M IPSTOR = MAX0(IPSTOR,IP+M) DO 131 I=1,M IP1 = IP+I P(IP1) = Q(I,J)+B(I) B(I) = Q(I,JP2)+P(IP1) 131 CONTINUE IF (LR .NE. 0) GO TO 133 DO 132 I=1,JST KRPI = KR+I TCOS(KRPI) = TCOS(I) 132 CONTINUE GO TO 134 133 CONTINUE CALL COSGEN (LR,JSTSAV,0.,FI,TCOS(JST+1)) CALL MERGE (TCOS,0,JST,JST,LR,KR) 134 CONTINUE CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) CALL TRIX (KR,KR,M,BA,BB,BC,B,TCOS,D,W) DO 135 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+B(I)+P(IP1) 135 CONTINUE LR = KR KR = KR+L GO TO 152 C C EVEN NUMBER OF UNKNOWNS C 136 JSP = JSP+L J = JSP JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST JM3 = JM2-JSH GO TO (137,138),IRREG 137 CONTINUE JSTSAV = JST IDEG = JST KR = L GO TO 139 138 CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR KR = KR+JST 139 IF (JST .NE. 1) GO TO 141 IRREG = 2 DO 140 I=1,M B(I) = Q(I,J) Q(I,J) = Q(I,JM2) 140 CONTINUE GO TO 150 141 DO 142 I=1,M B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3)) 142 CONTINUE GO TO (143,145),IRREG 143 DO 144 I=1,M Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1)) 144 CONTINUE IRREG = 2 GO TO 150 145 CONTINUE GO TO (146,148),NODDPR 146 DO 147 I=1,M IP1 = IP+I Q(I,J) = Q(I,JM2)+P(IP1) 147 CONTINUE IP = IP-M GO TO 150 148 DO 149 I=1,M Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1) 149 CONTINUE 150 CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) DO 151 I=1,M Q(I,J) = Q(I,J)+B(I) 151 CONTINUE 152 NUN = NUN/2 NODDPR = NODD JSH = JST JST = 2*JST IF (NUN .GE. 2) GO TO 108 C C START SOLUTION. C J = JSP DO 153 I=1,M B(I) = Q(I,J) 153 CONTINUE GO TO (154,155),IRREG 154 CONTINUE CALL COSGEN (JST,1,0.5,0.0,TCOS) IDEG = JST GO TO 156 155 KR = LR+JST CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR 156 CONTINUE CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W) JM1 = J-JSH JP1 = J+JSH GO TO (157,159),IRREG 157 DO 158 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 158 CONTINUE GO TO 164 159 GO TO (160,162),NODDPR 160 DO 161 I=1,M IP1 = IP+I Q(I,J) = P(IP1)+B(I) 161 CONTINUE IP = IP-M GO TO 164 162 DO 163 I=1,M Q(I,J) = Q(I,J)-Q(I,JM1)+B(I) 163 CONTINUE 164 CONTINUE C C START BACK SUBSTITUTION. C JST = JST/2 JSH = JST/2 NUN = 2*NUN IF (NUN .GT. N) GO TO 183 DO 182 J=JST,N,L JM1 = J-JSH JP1 = J+JSH JM2 = J-JST JP2 = J+JST IF (J .GT. JST) GO TO 166 DO 165 I=1,M B(I) = Q(I,J)+Q(I,JP2) 165 CONTINUE GO TO 170 166 IF (JP2 .LE. N) GO TO 168 DO 167 I=1,M B(I) = Q(I,J)+Q(I,JM2) 167 CONTINUE IF (JST .LT. JSTSAV) IRREG = 1 GO TO (170,171),IRREG 168 DO 169 I=1,M B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2) 169 CONTINUE 170 CONTINUE CALL COSGEN (JST,1,0.5,0.0,TCOS) IDEG = JST JDEG = 0 GO TO 172 171 IF (J+L .GT. N) LR = LR-JST KR = JST+LR CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS) CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1)) IDEG = KR JDEG = LR 172 CONTINUE CALL TRIX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W) IF (JST .GT. 1) GO TO 174 DO 173 I=1,M Q(I,J) = B(I) 173 CONTINUE GO TO 182 174 IF (JP2 .GT. N) GO TO 177 175 DO 176 I=1,M Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I) 176 CONTINUE GO TO 182 177 GO TO (175,178),IRREG 178 IF (J+JSH .GT. N) GO TO 180 DO 179 I=1,M IP1 = IP+I Q(I,J) = B(I)+P(IP1) 179 CONTINUE IP = IP-M GO TO 182 180 DO 181 I=1,M Q(I,J) = B(I)+Q(I,J)-Q(I,JM1) 181 CONTINUE 182 CONTINUE L = L/2 GO TO 164 183 CONTINUE C C RETURN STORAGE REQUIREMENTS FOR P VECTORS. C W(1) = IPSTOR RETURN END FUNCTION PIMACH (DUM) C C THIS SUBPROGRAM SUPPLIES THE VALUE OF THE CONSTANT PI CORRECT TO C MACHINE PRECISION WHERE C C PI=3.1415926535897932384626433832795028841971693993751058209749446 C PIMACH = 3.14159265358979 RETURN END SUBROUTINE DY4(U,IDMN,I,J,UYYY,UYYYY) C C THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE C APPROXIMATIONS TO THE THIRD AND FOURTH Y C PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT C COMMON /SPL4/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 DIMENSION U(IDMN,1) IF (J.GT.2 .AND. J.LT.(L-1)) GO TO 50 IF (J .EQ. 1) GO TO 10 IF (J .EQ. 2) GO TO 30 IF (J .EQ. L-1) GO TO 60 IF (J .EQ. L) GO TO 80 C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C C 10 IF (KSWY .EQ. 1) GO TO 20 UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)- 1 3.0*U(I,5))/TDLY3 UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+ 1 11.0*U(I,5)-2.0*U(I,6))/DLY4 RETURN C C PERIODIC AT X=A C 20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3 UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY C 30 IF (KSWY .EQ. 1) GO TO 40 UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/ 1 TDLY3 UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)- 1 U(I,6))/DLY4 RETURN C C PERIODIC AT Y=C+DLY C 40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3 UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR C 50 CONTINUE UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3 UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/ 1 DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY C 60 IF (KSWY .EQ. 1) GO TO 70 UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+ 1 3.0*U(I,L))/TDLY3 UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)- 1 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 RETURN C C PERIODIC AT Y=D-DLY C 70 CONTINUE UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3 UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/ 1 DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D C 80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+ 1 5.0*U(I,L))/TDLY3 UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)- 1 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 RETURN END