0000001 program V2_RIS 0000002 C 0000003 C--- 0000004 C Same version as published in W.L. Mattice and U.W. Suter, "Conformational 0000005 C Theory of Large Molecules," John Wiley & Sons, 1994, Appendic C, pp 429-436. 0000006 C References to equations are for the same book. 0000007 C--- 0000008 C Computes the exact average of a vector V that is the sum of 0000009 C contributions V(i), rigidly connected to the skeletal bonds of polymer 0000010 C chains of regular constitution and configuration. 0000011 C 0000012 C The program is capable of handling any number of bonds/unit, but not 0000013 C more than NU rotational isomeric states/bond (NU is a PARAMETER). The 0000014 C chain length increases step-wise by a factor of 2; the maximum length is 0000015 C selected by the number of steps ("loops") LMAX [max. X = 2**(LMAX-1)]. 0000016 C 0000017 C Matrices are normalized in each step to prevent numerical overflow or 0000018 C underflow and there is no strict upper bound to the chain length. 0000019 C Roundoff error, however, can corrupt the results for very long chains; 0000020 C adjustment of the quantity EPSILON (a parameter in subroutine NRMLZ) 0000021 C allows for maximum (machine-dependent!) accuracy without underflow 0000022 C errors (EPSILON = 10**(-24) is a reasonable setting for most computers). 0000023 C--- 0000024 C Attention: Line 9 of the subroutine VMATV, p 436 of the book, contains a 0000025 C printing error: the last variable, declared as "R(*)", should read "VR(*)". 0000026 C--- 0000027 C (C) Copyright 1993 : Wayne L. Mattice & Ulrich W. Suter 0000028 C--- 0000029 integer I, II, IN, J, JJ, JN, L, LMAX, M, M1, M5, MAXL, MOLD, N, 0000030 & N5, NBPU, NOLD, NU, NUN, NUNIT, 0000031 & LNBLNK 0000032 parameter (NU=6) 0000033 character TITLE*80 0000034 real*8 PHI(NU), THETA(NU), U(NU,NU), UI(NU,NU), U1(NU), UX(NU), 0000035 & VEC(3), VECN(3), VEC1(3), 0000036 & G(5,5), GG(5*NU,5*NU), GGI(5*NU,5*NU), GG1(5*NU), 0000037 & GGX(5*NU), TMP(5*NU,5*NU), 0000038 & C, CINF, COLD, ENLSQ, FAC, FG, GMAX, LNZ, SUMVEC, UMAX, 0000039 & VEC1N, VM2, XINV, Z, ZFAC 0000040 data U1 / NU*0. / 0000041 data UX / NU*1. / 0000042 C--- 0000043 C Format statements too long to fit into the write statements themselves: 0000044 C 0000045 1 format ('1Characteristic Ratio of 0 for', 0000046 & ' Chains with Regular Constitution',//, 0000047 & 1x,' +++ ',a,' +++',///, 0000048 & ' Number of bonds per unit =',i3,/, 0000049 & ' Longest chain :',i14,' units') 0000050 2 format (//,' Bond',i3,' : ',i3,' x',i3,' U-matrix',10x, 0000051 & 'associated vector =',3f8.4,/) 0000052 3 format (1h1,//,1x,' +++ ',a,' +++',///, 0000053 & ' Dimension of U(unit) =',i3,' x',i3,/) 0000054 4 format (//,10x,'X',5x,'1/X',8x,'ln(Z)',14x,'',6x,'C(X)', 0000055 & 7x,'est. C(inf)',/) 0000056 C--- 0000057 C Initialize matrices to unit-matrices for later convenience 0000058 C 0000059 U1(1) = 1. 0000060 50 do 70 I = 1, NU 0000061 do 60 J=1,NU 0000062 60 U(I,J) = 0. 0000063 70 U(I,I) = 1. 0000064 do 90 I=1,5*NU 0000065 do 80 J=1,5*NU 0000066 80 GG(I,J) = 0. 0000067 90 GG(I,I) = 1. 0000068 C 0000069 C Read running TITLE for all pages 0000070 C 0000071 read (*,'(a)',end=900) TITLE 0000072 C 0000073 C Read # of bonds/unit & # of chain length loops [max.X = 2**(LMAX-1)]. 0000074 C Defaults are: NBPU : none, LMAX : 10 0000075 C 0000076 SUMVEC = 0. 0000077 read (*,*,end=900) NBPU, LMAX 0000078 if (LMAX.le.0) LMAX = 10 0000079 MAXL = 2**(LMAX-1) 0000080 write (*,1) TITLE(1:LNBLNK(TITLE)), NBPU, MAXL 0000081 C 0000082 C Read U-matrices and vectors associated with the bonds, then 0000083 C torison angles and bond angles for each unit. Running sum for V**2. 0000084 C 0000085 do 300 NUN=1,NBPU 0000086 read (*,*,end=900) M, N, (VEC(I),I=1,3) 0000087 SUMVEC = SUMVEC + VEC(1)**2 + VEC(2)**2 + VEC(3)**2 0000088 if (NUN.eq.1) then 0000089 M1 = M 0000090 MOLD = M 0000091 NOLD = M 0000092 endif 0000093 write (*,2) NUN, M, N, (VEC(I),I=1,3) 0000094 if (M.ne.NOLD) go to 800 0000095 if ((NUN.eq.NBPU).and.(N.ne.M1)) go to 800 0000096 if (NUN.eq.1) then 0000097 VECN(1) = VEC(1) 0000098 VECN(2) = VEC(2) 0000099 VECN(3) = VEC(3) 0000100 endif 0000101 if (NUN.eq.NBPU) then 0000102 VEC1(1) = VEC(1) 0000103 VEC1(2) = VEC(2) 0000104 VEC1(3) = VEC(3) 0000105 endif 0000106 do 130 I=1,M 0000107 read (*,*,end=900) (UI(I,J),J=1,N) 0000108 130 write (*,'(1x,10f12.6)') (UI(I,J),J=1,N) 0000109 write (*,'(/,a)') ' Torsion angles' 0000110 read (*,*,end=900) (PHI(I),I=1,N) 0000111 write (*,'(1x,10f12.1)') (PHI(I),I=1,N) 0000112 write (*,'(/,a)') ' Bond angles' 0000113 read (*,*,end=900) (THETA(I),I=1,N) 0000114 C 0000115 C - default for any THETA-angle beyond the first: take the previously 0000116 C defined one (if THETA is the same for all PHI's of a bond, simply 0000117 C add zero's to complete the number required by the input statement). 0000118 C 0000119 do 140 I=2,N 0000120 140 if (THETA(I).lt.1.) THETA(I) = THETA(I-1) 0000121 write (*,'(1x,10f12.1)') (THETA(I),I=1,N) 0000122 C 0000123 C Now compute U(unit) and GG(unit) (=Script-G(unit)) as running product. 0000124 C First U 0000125 C 0000126 call MATMAT (U,UI,U,NU,MOLD,M,N,TMP,5*NU) 0000127 C 0000128 C Now Script-G (according to equation (VI-51), with A replaced by G) 0000129 C 0000130 M5 = 5*(M-1) + 1 0000131 N5 = 5*(N-1) + 1 0000132 do 160 J=1,N5,5 0000133 JN = 1 + J/5 0000134 call GMAT (THETA(JN),PHI(JN),VEC,G) 0000135 do 160 I=1,M5,5 0000136 IN = 1 + I/5 0000137 do 160 II=1,5 0000138 do 160 JJ=1,5 0000139 160 GGI(II+I-1,JJ+J-1) = G(II,JJ)*UI(IN,JN) 0000140 call MATMAT (GG,GGI,GG,5*NU,5*MOLD,5*M,5*N,TMP,5*NU) 0000141 C 0000142 C Now compute Script-G for first and last bond (GG1 and GGX) 0000143 C according to equations (VI-50) and (VI-52) with A replaced by G 0000144 C (the first bond of the chain is taken as the last bond of the repeat unit, 0000145 C occurring once before the repetition starts, the last bond as the first 0000146 C bond of the repeat unit, taken once after the repetition ends - hence, 0000147 C the chain-length will be equal to the [number of units]*NBPU + 2). 0000148 C 0000149 if (MOLD.lt.M) MOLD = M 0000150 NOLD = N 0000151 if (NUN.le.1) then 0000152 do 170 I=1,M5,5 0000153 do 170 II=1,5 0000154 170 GGX(I+II-1) = G(II,5) 0000155 endif 0000156 if (NUN.ge.NBPU) then 0000157 do 190 I=1,5 0000158 190 GG1(I) = G(1,I) 0000159 do 200 I=6,5*NU 0000160 200 GG1(I) = 0. 0000161 endif 0000162 300 continue 0000163 C 0000164 C Ready for looping over chain length. 0000165 C First write summery of setup, then go ... 0000166 C 0000167 write (*,3) TITLE(1:LNBLNK(TITLE)), M1, N 0000168 do 350 I=1,N 0000169 350 write (*,'(1x,10f12.6)') (U(I,J),J=1,N) 0000170 write (*,'(/,1x,a,f10.4,/)') 0000171 & 'Sum of mean-square length of vectors / unit =', SUMVEC 0000172 write (*,4) 0000173 NUNIT = 1 0000174 FAC = 0. 0000175 ZFAC = 0. 0000176 VEC1N = VEC1(1)**2 + VEC1(2)**2 + VEC1(3)**2 0000177 & + VECN(1)**2 + VECN(2)**2 + VECN(3)**2 0000178 C 0000179 C Now loop 0000180 C 0000181 do 500 L=1,LMAX 0000182 C 0000183 C - calculate Z, Z, , V[av]**2 (V[av] is the rms average 0000184 C of V(i) over the entire chain), and C(X)=/(N*V[av]**2). 0000185 C 0000186 call VMATV (U1,U,UX,NU,N,Z,TMP) 0000187 call VMATV (GG1,GG,GGX,5*NU,5*N,FG,TMP) 0000188 LNZ = ZFAC + log(Z) 0000189 VM2 = exp(FAC)*FG/Z 0000190 ENLSQ = real(NUNIT)*SUMVEC + VEC1N 0000191 C = VM2/ENLSQ 0000192 XINV = 1./real(NUNIT) 0000193 C 0000194 C - extrapolate and write results. 0000195 C 0000196 if (L.ge.2) then 0000197 CINF = 2*C - COLD 0000198 write (*,'(i11,2e12.4,f17.2,f11.4,f15.4)') 0000199 & NUNIT, XINV, LNZ, VM2, C, CINF 0000200 else 0000201 write (*,'(i11,2e12.4,f17.2,f11.4)') 0000202 & NUNIT, XINV, LNZ, VM2, C 0000203 endif 0000204 if (L.lt.LMAX) then 0000205 COLD = C 0000206 C - prevent overflow and underflow by conditioning U and GG. 0000207 call NRMLZ (U,NU,N,UMAX) 0000208 call NRMLZ (GG,5*NU,5*N,GMAX) 0000209 FAC = FAC + log(GMAX) - log(UMAX) 0000210 ZFAC = ZFAC + log(UMAX) 0000211 C - square U and GG for double chain length. 0000212 call MATMAT (U,U,U,NU,N,N,N,TMP,5*NU) 0000213 call MATMAT (GG,GG,GG,5*NU,5*N,5*N,5*N,TMP,5*NU) 0000214 NUNIT = 2*NUNIT 0000215 FAC = 2*FAC 0000216 ZFAC = 2*ZFAC 0000217 endif 0000218 500 continue 0000219 C and restart. 0000220 go to 50 0000221 C That's it. 0000222 800 write (*,'(/,a)') ' ***** WRONG DIMENSIONS *****' 0000223 900 write (*,'(///,1x,a)') '***** End of run *****' 0000224 end ENTRY POINTS Name Type BlockNo MAIN_ 4 v2_ris 3 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References MAIN_ 1D __set_f77vms_flag SUBR EXTERNAL 224 exp INTRINSIC 189 gmat SUBR EXTERNAL 134 lnblnk I*4 EXTERNAL 29D 80 167 log INTRINSIC 188 209(2) 210 matmat SUBR EXTERNAL 126 140 212 213 nrmlz SUBR EXTERNAL 207 208 real INTRINSIC 190 192 v2_ris 1D vmatv SUBR EXTERNAL 186 187 PARAMETERS Name Type References nu I*4 29D 32D 34(32)D 60 61 64 65 126(2) 140(2) 159 186 187 207 208 212(2) 213(2) VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References c R*8 VAR AUTO 34 191= 197 198 201 205 cinf R*8 VAR AUTO 34 197= 198 cold R*8 VAR AUTO 34 197 205= enlsq R*8 VAR AUTO 34 190= 191 fac R*8 VAR AUTO 34 174= 189A 209(2)= 215(2)= fg R*8 VAR AUTO 34 187A 189 g R*8 (5,5) VAR AUTO 34 134A 139 154 158 gg R*8 (30,30) VAR AUTO 34 66= 67= 140(2)A 187A 208A 213(3)A gg1 R*8 (30) VAR AUTO 34 158= 160= 187A ggi R*8 (30,30) VAR AUTO 34 139= 140A ggx R*8 (30) VAR AUTO 34 154= 187A gmax R*8 VAR AUTO 34 208A 209A i I*4 VAR AUTO 29D 60= 62 63(3)= 64= 66 67(3)= 86(2)= 93(2) 106= 107 108(2)= 110(2)= 111(2) 113(2)= 119= 120(4)= 121(2) 135= 136 139(2)= 152= 154(2)= 157= 158(3)= 159= 160(2)= 168= 169(2)= ii I*4 VAR AUTO 29D 137= 139(3)= 153= 154(3)= in I*4 VAR AUTO 29D 136= 139 j I*4 VAR AUTO 29D 61= 62(2)= 65= 66(2)= 107(3)= 108(3)= 132= 133 139(2)= 169(3)= jj I*4 VAR AUTO 29D 138= 139(3)= jn I*4 VAR AUTO 29D 133= 134(2) 139 l I*4 VAR AUTO 29D 181= 196 204 218= lmax I*4 VAR AUTO 29D 77= 78(2)= 79 181 204 lnz R*8 VAR AUTO 34 188= 198 201 m I*4 VAR AUTO 29D 86= 89 90 91 93 94 106 126A 130 140 149(2) m1 I*4 VAR AUTO 29D 89= 95 167 m5 I*4 VAR AUTO 29D 130= 135 152 maxl I*4 VAR AUTO 29D 79= 80 mold I*4 VAR AUTO 29D 90= 126A 140 149(2)= n I*4 VAR AUTO 29D 86= 93 95 107 108 110(2) 111(2) 113(2) 119 121(2) 126A 131 140 150 167 168 169 186A 187 207A 208 212(3)A 213(3) n5 I*4 VAR AUTO 29D 131= 132 nbpu I*4 VAR AUTO 29D 77= 80 85 95 101 156 nold I*4 VAR AUTO 29D 91= 94 150= nun I*4 VAR AUTO 29D 85= 88 93 95 96 101 151 156 162= nunit I*4 VAR AUTO 29D 173= 190A 192A 198 201 214(2)= phi R*8 (6) VAR AUTO 34D 110= 111 134A sumvec R*8 VAR AUTO 34 76= 87(2)= 170 190 theta R*8 (6) VAR AUTO 34 113= 120(3)= 121 134A title CH*80 VAR AUTO 33D 71= 80(2)A 167(2)A tmp R*8 (30,30) VAR AUTO 34 126A 140A 186A 187A 212A 213A u R*8 (6,6) VAR AUTO 34 62= 63= 126(2)A 169 186A 207A 212(3)A u1 R*8 (6) VAR DATA 34 40I 59= 186A ui R*8 (6,6) VAR AUTO 34 107= 108 126A 139 umax R*8 VAR AUTO 34 207A 209A 210A ux R*8 (6) VAR DATA 34 41I 186A vec R*8 (3) VAR AUTO 34 86= 87(3) 93 97 98 99 102 103 104 134A vec1 R*8 (3) VAR AUTO 34 102= 103= 104= 176(3) vec1n R*8 VAR AUTO 34 176= 190 vecn R*8 (3) VAR AUTO 34 97= 98= 99= 176(3) vm2 R*8 VAR AUTO 34 189= 191 198 201 vms_compatible I*4 (2) VAR AUTO 224(3)= xinv R*8 VAR AUTO 34 192= 198 201 z R*8 VAR AUTO 34 186A 188A 189 zfac R*8 VAR AUTO 34 175= 188 210(2)= 216(2)= LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 1 45 4 54 70 63 130 108 170 154 300 162 800 222 2 50 50 60 80 66 140 120 190 158 350 169 900 223 3 52 60 62 90 67 160 139 200 160 500 218 0000225 C 0000226 subroutine GMAT (THETA,PHI,V,G) 0000227 C--- 0000228 C Sets up the generator matrix G for V**2, given scalar values of 0000229 C THETA(i), PHI(i), and the vector V(i), according to equation (VI-21). 0000230 C--- 0000231 real*8 G(5,*), V(*), T(3,3), 0000232 & PHI, THETA 0000233 integer I, J 0000234 C--- 0000235 do 100 I=1,5 0000236 do 100 J=1,5 0000237 100 G(I,J) = 0. 0000238 C 0000239 C Transformation matrix T according to equation (VI-5). 0000240 C 0000241 call TMAT (THETA,PHI,T) 0000242 C 0000243 do 110 I=2,4 0000244 do 110 J=2,4 0000245 110 G(I,J) = T(I-1,J-1) 0000246 G(1,1) = 1. 0000247 G(1,2) = 2.*(V(1)*T(1,1) + V(2)*T(2,1) + V(3)*T(3,1)) 0000248 G(1,3) = 2.*(V(1)*T(1,2) + V(2)*T(2,2) + V(3)*T(3,2)) 0000249 G(1,4) = 2.*(V(1)*T(1,3) + V(2)*T(2,3) + V(3)*T(3,3)) 0000250 G(1,5) = V(1)**2 + V(2)**2 + V(3)**2 0000251 G(2,5) = V(1) 0000252 G(3,5) = V(2) 0000253 G(4,5) = V(3) 0000254 G(5,5) = 1. 0000255 return 0000256 end ENTRY POINTS Name Type BlockNo gmat SUBR 61 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References gmat SUBR 226D tmat SUBR EXTERNAL 241 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References g R*8 (5,1) VAR ARG 92 0 226D 231D 237= 245= 246= 247= 248= 249= 250= 251= 252= 253= 254= i I*4 VAR AUTO 233D 235= 237(2)= 243= 245(3)= j I*4 VAR AUTO 233D 236= 237(2)= 244= 245(3)= phi R*8 VAR ARG 90 0 226D 231D 241A t R*8 (3,3) VAR AUTO 231D 241A 245 247(3) 248(3) 249(3) theta R*8 VAR ARG 89 0 226D 231D 241A v R*8 (1) VAR ARG 91 0 226D 231D 247(3) 248(3) 249(3) 250(3) 251 252 253 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 237 110 245 0000257 C 0000258 integer function LNBLNK (STRING) 0000259 C--- 0000260 C Returns the location of the last non-blank character in string STRING. 0000261 C--- 0000262 character STRING*(*) 0000263 integer I 0000264 C--- 0000265 do 100 I=len(STRING),1,-1 0000266 100 if (STRING(I:I).ne.' ') go to 200 0000267 I = 0 0000268 200 LNBLNK = I 0000269 return 0000270 end ENTRY POINTS Name Type BlockNo lnblnk I*4 32 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References len INTRINSIC 265 lnblnk I*4 258D 268= VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References i I*4 VAR AUTO 263D 265= 266(4)= 267= 268 string CH*(*) VAR ARG 100 0 258D 262D 265A 266 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 266 200 268 0000271 C 0000272 subroutine MATMAT (A,B,AB,MM,MA,MB,NB,TMP,MTMP) 0000273 C--- 0000274 C Multiplies matrix A (MAxMB) with matrix B (MBxNB) and stores 0000275 C the result in matrix AB (MAxNB). AB can be one of A or B. 0000276 C The first dimension of the arrays containing A, B, and AB in the 0000277 C calling program's defining statement is MM. 0000278 C The first dimension of the array containing TMP in the 0000279 C calling program's defining statement is MTMP. 0000280 C--- 0000281 real*8 A(MM,*), B(MM,*), AB(MM,*), TMP(MTMP,*), 0000282 & X 0000283 integer I, J, K, MA, MB, MM, NB 0000284 C--- 0000285 do 100 I=1,MA 0000286 do 100 J=1,NB 0000287 X = 0. 0000288 do 90 K=1,MB 0000289 90 X = X + A(I,K)*B(K,J) 0000290 100 TMP(I,J) = X 0000291 C 0000292 do 200 I=1,MA 0000293 do 200 J=1,NB 0000294 200 AB(I,J) = TMP(I,J) 0000295 return 0000296 end ENTRY POINTS Name Type BlockNo matmat SUBR 57 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References matmat SUBR 272D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (*,1) VAR ARG 108 0 272D 281D 289 ab R*8 (*,1) VAR ARG 110 0 272D 281D 294= b R*8 (*,1) VAR ARG 109 0 272D 281D 289 i I*4 VAR AUTO 283D 285= 289 290(2)= 292= 294(3)= j I*4 VAR AUTO 283D 286= 289 290(2)= 293= 294(3)= k I*4 VAR AUTO 283D 288= 289(3)= ma I*4 VAR ARG 112 0 272D 283D 285 292 mb I*4 VAR ARG 113 0 272D 283D 288 mm I*4 VAR ARG 111 0 272D 281(3)D 283D 296(6) mtmp I*4 VAR ARG 116 0 272D 281D 296(2) nb I*4 VAR ARG 114 0 272D 283D 286 293 tmp R*8 (*,1) VAR ARG 115 0 272D 281D 290= 294 x R*8 VAR AUTO 281D 287= 289(2)= 290 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 90 289 100 290 200 294 0000297 C 0000298 subroutine NRMLZ (A,MM,N,FAC) 0000299 C--- 0000300 C Divides every element of square matrix A (NxN) by that with the largest 0000301 C magnitude, FAC. Set elements that are smaller than EPSILON in magnitude 0000302 C to true zero (EPSILON is a PARAMETER). 0000303 C The first dimension of the array containing A in the 0000304 C calling program's defining statement is MM. 0000305 C--- 0000306 real*8 A(MM,*), 0000307 & EPSILON, FAC 0000308 integer I, J, MM, N 0000309 parameter (EPSILON=1.0d-24) 0000310 C--- 0000311 FAC = 0. 0000312 do 100 I=1,N 0000313 do 100 J=1,N 0000314 100 FAC = max(FAC,abs(A(I,J))) 0000315 C 0000316 do 200 I=1,N 0000317 do 200 J=1,N 0000318 A(I,J) = A(I,J)/FAC 0000319 200 if (abs(A(I,J)).lt.EPSILON) A(I,J) = 0. 0000320 return 0000321 end ENTRY POINTS Name Type BlockNo nrmlz SUBR 80 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References abs INTRINSIC 314 319 max INTRINSIC 314 nrmlz SUBR 298D PARAMETERS Name Type References epsilon R*8 306D 309D 319 VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (*,1) VAR ARG 123 0 298D 306D 314A 318(2)= 319(2)= fac R*8 VAR ARG 126 0 298D 306D 311= 314(2)= 318 i I*4 VAR AUTO 308D 312= 314(2)= 316= 318(2) 319(3)= j I*4 VAR AUTO 308D 313= 314(2)= 317= 318(2) 319(3)= mm I*4 VAR ARG 124 0 298D 306D 308D 321(2) n I*4 VAR ARG 125 0 298D 308D 312 313 316 317 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 100 314 200 319 0000322 C 0000323 subroutine TMAT (THETA,PHI,T) 0000324 C--- 0000325 C Sets up the transformation matrix T according to equation (VI-4). 0000326 C--- 0000327 real*8 T(3,*), 0000328 & COSTHT, COSPHI, PHI, SINTHT, SINPHI, THETA 0000329 integer I, J 0000330 C--- 0000331 COSTHT = cos(THETA*3.1415926535/180.) 0000332 SINTHT = sin(THETA*3.1415926535/180.) 0000333 COSPHI = cos(PHI*3.1415926535/180.) 0000334 SINPHI = sin(PHI*3.1415926535/180.) 0000335 T(1,1) = - COSTHT 0000336 T(1,2) = SINTHT 0000337 T(1,3) = 0. 0000338 T(2,1) = - SINTHT * COSPHI 0000339 T(2,2) = - COSTHT * COSPHI 0000340 T(2,3) = - SINPHI 0000341 T(3,1) = - SINTHT * SINPHI 0000342 T(3,2) = - COSTHT * SINPHI 0000343 T(3,3) = COSPHI 0000344 C 0000345 return 0000346 end ENTRY POINTS Name Type BlockNo tmat SUBR 95 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References cos INTRINSIC 331 333 sin INTRINSIC 332 334 tmat SUBR 323D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References cosphi R*8 VAR AUTO 327D 333= 338 339 343 costht R*8 VAR AUTO 327D 331= 335 339 342 i I*4 VAR 329D Variable declared and not used j I*4 VAR 329D Variable declared and not used phi R*8 VAR ARG 134 0 323D 327D 333 334 sinphi R*8 VAR AUTO 327D 334= 340 341 342 sintht R*8 VAR AUTO 327D 332= 336 338 341 t R*8 (3,1) VAR ARG 135 0 323D 327D 335= 336= 337= 338= 339= 340= 341= 342= 343= theta R*8 VAR ARG 133 0 323D 327D 331 332 0000347 C 0000348 subroutine VMATV (VL,A,VR,MM,M,RESULT,TMP) 0000349 C--- 0000350 C Forms the bylinear product from the vector VL, 0000351 C the square matrix A (MxM), and the vector VR: 0000352 C RESULT = VL(transpose) A VR 0000353 C The first dimension of the array containing A in the 0000354 C calling program's defining statement is MM. 0000355 C--- 0000356 real*8 A(MM,*), TMP(*), VL(*), VR(*), 0000357 & RESULT, X 0000358 integer I, K, MM, M 0000359 C--- 0000360 do 100 I=1,M 0000361 X = 0. 0000362 do 90 K=1,M 0000363 90 X = X + VL(K)*A(K,I) 0000364 100 TMP(I) = X 0000365 X = 0. 0000366 C 0000367 do 200 I=1,M 0000368 200 X = X + TMP(I)*VR(I) 0000369 RESULT = X 0000370 return 0000371 end ENTRY POINTS Name Type BlockNo vmatv SUBR 73 FUNCTION AND SUBROUTINE REFERENCES Name Type ProcType References vmatv SUBR 348D VARIABLES REFERENCES Name Type Dimension Class Storage BlockNo Offset References a R*8 (*,1) VAR ARG 142 0 348D 356D 363 i I*4 VAR AUTO 358D 360= 363 364(2)= 367= 368(3)= k I*4 VAR AUTO 358D 362= 363(3)= m I*4 VAR ARG 145 0 348D 358D 360 362 367 mm I*4 VAR ARG 144 0 348D 356D 358D 371(2) result R*8 VAR ARG 146 0 348D 356D 369= tmp R*8 (1) VAR ARG 147 0 348D 356D 364= 368 vl R*8 (1) VAR ARG 141 0 348D 356D 363 vr R*8 (1) VAR ARG 143 0 348D 356D 368 x R*8 VAR AUTO 356D 361= 363(2)= 364 365= 368(2)= 369 LABELS LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo LabNo LinNo 90 363 100 364 200 368 +--------------------------------------------+ | : Referenced but not modified | | = : Value modified | | A : Actual argument, possibly modified | | D : Declared/Defined | | I : Data Initialization | | (n) : Number of occurrences | | # : Unknown usage | +--------------------------------------------+