PyFishPack 0.1.0__cp313-cp313-win_amd64.whl

PyFishPack/src/archive/f77/gnbnaux.f

@@ -0,0 +1,314 @@
+C
+C     file gnbnaux.f
+C
+C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+C     *                                                               *
+C     *                  copyright (c) 1999 by UCAR                   *
+C     *                                                               *
+C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
+C     *                                                               *
+C     *                      all rights reserved                      *
+C     *                                                               *
+C     *                      FISHPACK version 4.1                     *
+C     *                                                               *
+C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
+C     *                                                               *
+C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
+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 PACKAGE GNBNAUX
+C
+C LATEST REVISION        NOVEMBER 1988
+C
+C PURPOSE                TO PROVIDE AUXILIARY ROUTINES FOR FISHPACK
+C                        ENTRIES GENBUN AND POISTG.
+C
+C USAGE                  THERE ARE NO USER ENTRIES IN THIS PACKAGE.
+C                        THE ROUTINES IN THIS PACKAGE ARE NOT INTENDED
+C                        TO BE CALLED BY USERS, BUT RATHER BY ROUTINES
+C                        IN PACKAGES GENBUN AND POISTG.
+C
+C SPECIAL CONDITIONS     NONE
+C
+C I/O                    NONE
+C
+C PRECISION              SINGLE
+C
+C REQUIRED LIBRARY       COMF FROM FISHPACK
+C FILES
+C
+C LANGUAGE               FORTRAN
+C
+C HISTORY                WRITTEN IN 1979 BY ROLAND SWEET OF NCAR'S
+C                        SCIENTIFIC COMPUTING DIVISION.  MADE AVAILABLE
+C                        ON NCAR'S PUBLIC LIBRARIES IN JANUARY, 1980.
+C
+C PORTABILITY            FORTRAN 77
+C ********************************************************************
+      SUBROUTINE COSGEN (N,IJUMP,FNUM,FDEN,A)
+      DIMENSION       A(*)
+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 MERGE (TCOS,I1,M1,I2,M2,I3)
+      DIMENSION       TCOS(*)
+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 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(*)       ,B(*)       ,C(*)       ,Y(*)       ,
+     1                TCOS(*)    ,D(*)       ,W(*)
+      MM1 = M-1
+      IFB = IDEGBR+1
+      IFC = IDEGCR+1
+      L = IFB/IFC
+      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 = (LINT*IFB)/IFC
+  108 CONTINUE
+      RETURN
+      END
+      SUBROUTINE TRI3 (M,A,B,C,K,Y1,Y2,Y3,TCOS,D,W1,W2,W3)
+      DIMENSION       A(*)       ,B(*)       ,C(*)       ,K(4)       ,
+     1                TCOS(*)    ,Y1(*)      ,Y2(*)      ,Y3(*)      ,
+     2                D(*)       ,W1(*)      ,W2(*)      ,W3(*)
+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)
+      IF1 = K1+1
+      IF2 = K2+1
+      IF3 = K3+1
+      IF4 = K4+1
+      K2K3K4 = K2+K3+K4
+      IF (K2K3K4 .EQ. 0) GO TO 101
+      L1 = IF1/IF2
+      L2 = IF1/IF3
+      L3 = IF1/IF4
+      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 = (LINT1*IF1)/IF2
+  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 = (LINT2*IF1)/IF3
+  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 = (LINT3*IF1)/IF4
+  115 CONTINUE
+      RETURN
+C
+C REVISION HISTORY---
+C
+C SEPTEMBER 1973    VERSION 1
+C APRIL     1976    VERSION 2
+C JANUARY   1978    VERSION 3
+C DECEMBER  1979    VERSION 3.1
+C OCTOBER   1980    CHANGED SEVERAL DIVIDES OF FLOATING INTEGERS
+C                   TO INTEGER DIVIDES TO ACCOMODATE CRAY-1 ARITHMETIC.
+C FEBRUARY  1985    DOCUMENTATION UPGRADE
+C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
+C-----------------------------------------------------------------------
+      END