*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.7 *IF DEF,A01_3A,OR,DEF,A02_3A BNSOL3A.2 C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13110 C GTS2F400.13111 C Use, duplication or disclosure of this code is subject to the GTS2F400.13112 C restrictions as set forth in the contract. GTS2F400.13113 C GTS2F400.13114 C Meteorological Office GTS2F400.13115 C London Road GTS2F400.13116 C BRACKNELL GTS2F400.13117 C Berkshire UK GTS2F400.13118 C RG12 2SZ GTS2F400.13119 C GTS2F400.13120 C If no contract has been raised with this copy of the code, the use, GTS2F400.13121 C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13122 C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13123 C Modelling at the above address. GTS2F400.13124 C ******************************COPYRIGHT****************************** GTS2F400.13125 C GTS2F400.13126 !+ Subroutine to solve a set of banded matrix equations. BNSOL3A.3 ! BNSOL3A.4 ! Method: BNSOL3A.5 ! A set of bands matrix equations is solved using the BNSOL3A.6 ! standard method of Gaussian elimination. BNSOL3A.7 ! BNSOL3A.8 ! Current Owner of Code: J. M. Edwards BNSOL3A.9 ! BNSOL3A.10 ! History: BNSOL3A.11 ! Version Date Comment BNSOL3A.12 ! 4.0 27-07-95 Original Code BNSOL3A.13 ! (J. M. Edwards) BNSOL3A.14 ! BNSOL3A.15 ! Description of Code: BNSOL3A.16 ! FORTRAN 77 with extensions listed in documentation. BNSOL3A.17 ! BNSOL3A.18 !- --------------------------------------------------------------------- BNSOL3A.19SUBROUTINE BAND_SOLVER(M, N 4BNSOL3A.20 & , IU, IL BNSOL3A.21 & , A, B BNSOL3A.22 & , X BNSOL3A.23 & , PM, PN BNSOL3A.24 & , RHO BNSOL3A.25 & ) BNSOL3A.26 ! BNSOL3A.27 ! BNSOL3A.28 IMPLICIT NONE BNSOL3A.29 ! BNSOL3A.30 ! BNSOL3A.31 ! DUMMY ARGUMENTS BNSOL3A.32 INTEGER !, INTENT(IN) BNSOL3A.33 & M BNSOL3A.34 ! NUMBER OF PROFILES BNSOL3A.35 & , N BNSOL3A.36 ! NUMBER OF EQUATIONS BNSOL3A.37 & , IU BNSOL3A.38 ! NUMBER OF SUPERDIAGONALS BNSOL3A.39 & , IL BNSOL3A.40 ! NUMBER OF SUBDIAGONALS BNSOL3A.41 & , PM BNSOL3A.42 ! FIRST ARRAY SIZE BNSOL3A.43 & , PN BNSOL3A.44 ! SECOND ARRAY SIZE BNSOL3A.45 REAL !, INTENT(IN) BNSOL3A.46 & A(PM, (1+IU+IL), PN) BNSOL3A.47 ! MATRIX OF COEFFICIENTS BNSOL3A.48 & , B(PM, PN) BNSOL3A.49 ! RIGHTHAND SIDES BNSOL3A.50 REAL !, INTENT(OUT) BNSOL3A.51 & X(PM, PN) BNSOL3A.52 ! SOLUTION VECTOR BNSOL3A.53 REAL !, INTENT(WORK) BNSOL3A.54 & RHO(PM) BNSOL3A.55 ! TEMPORARY ARRAY BNSOL3A.56 ! BNSOL3A.57 ! LOCAL VARIABLES BNSOL3A.58 INTEGER BNSOL3A.59 & I BNSOL3A.60 ! LOOP VARIABLE BNSOL3A.61 & , J BNSOL3A.62 ! LOOP VARIABLE BNSOL3A.63 & , K BNSOL3A.64 ! LOOP VARIABLE BNSOL3A.65 & , L BNSOL3A.66 ! LOOP VARIABLE BNSOL3A.67 & , IU1 BNSOL3A.68 ! LOCAL SCALAR BNSOL3A.69 ! BNSOL3A.70 ! BNSOL3A.71 IU1=IU+1 BNSOL3A.72 ! ELIMINATIVE PHASE. BNSOL3A.73 DO I=N, 2, -1 BNSOL3A.74 DO J=1, MIN(IU, I-1) BNSOL3A.75 DO L=1, M BNSOL3A.76 RHO(L)=A(L, IU1-J, I-J)/A(L, IU1, I) BNSOL3A.77 B(L, I-J)=B(L, I-J)-RHO(L)*B(L, I) BNSOL3A.78 ENDDO BNSOL3A.79 DO K=1, MIN(IL, I-1) BNSOL3A.80 DO L=1, M BNSOL3A.81 A(L, IU1+K-J, I-J)=A(L, IU1+K-J, I-J) BNSOL3A.82 & -RHO(L)*A(L, IU1+K, I) BNSOL3A.83 ENDDO BNSOL3A.84 ENDDO BNSOL3A.85 ENDDO BNSOL3A.86 ENDDO BNSOL3A.87 ! BNSOL3A.88 ! SOLUTION AND BACK-SUBSTITUTION: BNSOL3A.89 ! BNSOL3A.90 IF ( (IU.EQ.2).AND.(IL.EQ.2) ) THEN BNSOL3A.91 ! A SPECIAL VERSION IS USED FOR THE PENTADIAGONAL CASE TO ALLOW BNSOL3A.92 ! US TO CHAIN OPERATIONS TOGETHER FOR EFFICIENCY ON THE CRAY. BNSOL3A.93 ! FIRST EQUATION: BNSOL3A.94 DO L=1, M BNSOL3A.95 X(L, 1)=B(L, 1)/A(L, 3, 1) BNSOL3A.96 ENDDO BNSOL3A.97 ! SECOND EQUATION: BNSOL3A.98 DO L=1, M BNSOL3A.99 X(L, 2)=(B(L, 2)-A(L, 4, 2)*X(L, 1))/A(L, 3, 2) BNSOL3A.100 ENDDO BNSOL3A.101 ! REMAINING EQUATIONS: BNSOL3A.102 DO I=3, N BNSOL3A.103 DO L=1, M BNSOL3A.104 X(L, I)=(B(L, I)-A(L, 4, I)*X(L, I-1) BNSOL3A.105 & -A(L, 5, I)*X(L, I-2))/A(L, 3, I) BNSOL3A.106 ENDDO BNSOL3A.107 ENDDO BNSOL3A.108 ELSE BNSOL3A.109 ! GENERAL CASE: BNSOL3A.110 DO I=1, N BNSOL3A.111 DO L=1, M BNSOL3A.112 X(L, I)=B(L, I) BNSOL3A.113 ENDDO BNSOL3A.114 DO K=1, MIN(IL, I-1) BNSOL3A.115 DO L=1, M BNSOL3A.116 X(L, I)=X(L, I)-A(L, IU1+K, I)*X(L, I-K) BNSOL3A.117 ENDDO BNSOL3A.118 ENDDO BNSOL3A.119 DO L=1, M BNSOL3A.120 X(L, I)=X(L, I)/A(L, IU1, I) BNSOL3A.121 ENDDO BNSOL3A.122 ENDDO BNSOL3A.123 ENDIF BNSOL3A.124 ! BNSOL3A.125 ! BNSOL3A.126 RETURN BNSOL3A.127 END BNSOL3A.128 *ENDIF DEF,A01_3A,OR,DEF,A02_3A BNSOL3A.129 *ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.8