Page 1 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 1 !/ ------------------------------------------------------------------- / 2 MODULE W3PROFSMD 3 !/ 4 !/ +-----------------------------------+ 5 !/ | WAVEWATCH III NOAA/NCEP | 6 !/ | Aron Roland | 7 !/ | Fabrice Ardhuin | 8 !/ | FORTRAN 90 | 9 !/ | Last update : 17-Oct-2013 | 10 !/ +-----------------------------------+ 11 !/ 12 !/ XX-Nov-2007 : Origination. ( version 3.10 ) 13 !/ 03-Nov-2011 : Adding shoreline reflection ( version 4.04 ) 14 !/ 03-Jun-2013 : Removed assign statements ( version 4.10 ) 15 !/ 20-Jun-2013 : Update test output for time steps ( version 4.10 ) 16 !/ 17-Oct-2013 : Removes boundary nodes from CFL ( version 4.12 ) 17 ! 18 ! 1. Purpose : 19 ! 20 ! Propagation schemes for unstructured grids using fluctuation splitting 21 ! 22 ! 2. Variables and types : 23 ! 24 ! Name Type Scope Description 25 ! ---------------------------------------------------------------- 26 ! ---------------------------------------------------------------- 27 ! 28 ! 3. Subroutines and functions : 29 ! 30 ! Name Type Scope Description 31 ! ---------------------------------------------------------------- 32 ! W3XYPUG Subr. Public Generic fluctuation splitting operations 33 ! W3XYPFSN2 Subr. Public advection with N scheme (Csik et al. 2002) 34 ! W3XYPFSPSI Subr. Public advection with FCT scheme 35 ! W3XYPFSFCT2 Subr. Public advection with FCT scheme 36 ! ---------------------------------------------------------------- 37 ! 38 ! 4. Subroutines and functions used : 39 ! 40 ! Name Type Module Description 41 ! ---------------------------------------------------------------- 42 ! ---------------------------------------------------------------- 43 ! 44 ! 5. Remarks : 45 ! For a detailed description of the schemes and their properties, see 46 ! Roland (2008), Ph.D. Thesis, T. U. Darmstadt. 47 ! 48 ! 6. Switches : 49 ! 50 ! 7. Source code : 51 !/ 52 !/ ------------------------------------------------------------------- / 53 !/ 54 PUBLIC 55 !/ 56 CONTAINS 57 !/ ------------------------------------------------------------------- / Page 2 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 58 SUBROUTINE W3XYPUG ( ISP, FACX, FACY, DTG, VQ, VGX, VGY, LCALC ) 59 !/ 60 !/ +-----------------------------------+ 61 !/ | WAVEWATCH III NOAA/NCEP | 62 !/ | Aron Roland | 63 !/ | FORTRAN 90 | 64 !/ | Last update : 10-Jan-2011 | 65 !/ +-----------------------------------+ 66 !/ 67 !/ 10-Jan-2008 : Origination. ( version 3.13 ) 68 !/ 10-Jan-2011 : Addition of implicit scheme ( version 3.14.4 ) 69 !/ 70 ! 1. Purpose : 71 ! 72 ! Propagation in physical space for a given spectral component. 73 ! Gives the choice of scheme on unstructured grid 74 ! 75 ! 2. Method : 76 ! 77 ! 3. Parameters : 78 ! 79 ! Parameter list 80 ! ---------------------------------------------------------------- 81 ! ISP Int. I Number of spectral bin (IK-1)*NTH+ITH 82 ! FACX/Y Real I Factor in propagation velocity. 83 ! ( 1 or 0 * DT / DX ) 84 ! DTG Real I Total time step. 85 ! VQ R.A. I/O Field to propagate. 86 ! VGX/Y Real I Speed of grid. 87 ! ---------------------------------------------------------------- 88 ! 89 ! Local variables. 90 ! ---------------------------------------------------------------- 91 ! VCFL0X R.A. Local courant numbers for absolute group vel. 92 ! using local X-grid step. 93 ! VCFL0Y R.A. Id. in Y. 94 ! ---------------------------------------------------------------- 95 ! 96 ! 4. Subroutines used : 97 ! 98 99 ! 5. Called by : 100 ! 101 ! W3WAVE Wave model routine. 102 ! 103 ! 6. Error messages : 104 ! 105 ! None. 106 ! 107 ! 7. Remarks : 108 ! make the interface between the WAVEWATCH and the WWM code. 109 ! 110 ! 8. Structure : 111 ! 112 ! 9. Switches : 113 ! 114 ! !/S Enable subroutine tracing. Page 3 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 115 ! 116 ! 10. Source code : 117 !/ ------------------------------------------------------------------- / 118 !/ 119 ! 120 USE CONSTANTS 121 ! 122 USE W3TIMEMD, ONLY: DSEC21 123 ! 124 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, MAPFS, DTCFL, CLATS, & 125 FLCX, FLCY, NK, NTH, DTH, XFR, & 126 ECOS, ESIN, SIG, PFMOVE,IEN, & 127 NTRI, TRIGP, CCON , & 128 IE_CELL, POS_CELL, IOBP, IOBPD, & 129 FSN, FSPSI, FSFCT, FSNIMP, GTYPE, UNGTYPE 130 131 USE W3WDATMD, ONLY: TIME 132 USE W3ODATMD, ONLY: TBPI0, TBPIN, FLBPI 133 USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, CFLXYMAX 134 USE W3IDATMD, ONLY: FLCUR 135 ! USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, & 136 ! ISBPI, BBPI0, BBPIN 137 138 IMPLICIT NONE 139 !/ ------------------------------------------------------------------- / 140 !/ Parameter list 141 !/ 142 INTEGER, INTENT(IN) :: ISP 143 REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY 144 REAL, INTENT(INOUT) :: VQ(1-NY:NY*(NX+2)) 145 LOGICAL, INTENT(IN) :: LCALC 146 LOGICAL :: SCHEME 147 !/ 148 !/ ------------------------------------------------------------------- / 149 !/ Local parameters 150 !/ 151 INTEGER :: ITH, IK, ISEA, IXY, IBI 152 INTEGER :: IX, IY, I, J, IE 153 REAL :: CCOS, CSIN, CCURX, CCURY 154 REAL :: C(NX,2) 155 REAL :: RD1, RD2 156 !/ 157 !/ Automatic work arrays 158 !/ 159 REAL :: VLCFLX((NX+1)*NY), VLCFLY(NX*NY) 160 REAL :: AQ(NX) 161 ! AQ(1-NY:NY*(NX+2)) 162 REAL :: AC(NX) 163 !/ ------------------------------------------------------------------- / 164 ! 165 ! 1. Preparations --------------------------------------------------- * 166 ! 1.a Set constants 167 ! 168 169 ITH = 1 + MOD(ISP-1,NTH) 170 IK = 1 + (ISP-1)/NTH 171 Page 4 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 172 CCOS = FACX * ECOS(ITH) 173 CSIN = FACY * ESIN(ITH) 174 CCURX = FACX 175 CCURY = FACY 176 ! 177 ! 1.b Initialize arrays 178 ! 179 VLCFLX = 0. 180 VLCFLY = 0. 181 ! 182 ! 2. Calculate velocities ---------------- * 183 ! 184 DO ISEA=1, NSEA 185 IXY = MAPSF(ISEA,3) 186 VQ(IXY) = VQ(IXY) / CG(IK,ISEA) * CLATS(ISEA) 187 VLCFLX(IXY) = CCOS * CG(IK,ISEA) / CLATS(ISEA) 188 VLCFLY(IXY) = CSIN * CG(IK,ISEA) 189 END DO 190 191 IF ( FLCUR ) THEN 192 DO ISEA=1, NSEA 193 IXY = MAPSF(ISEA,3) 194 ! 195 ! Currents are not included on coastal boundaries (IOBP(IXY).EQ.0) 196 ! 197 IF (IOBP(IXY) .EQ. 1) THEN 198 VLCFLX(IXY) = VLCFLX(IXY) + CCURX*CX(ISEA)/CLATS(ISEA) 199 VLCFLY(IXY) = VLCFLY(IXY) + CCURY*CY(ISEA) 200 !ELSE 201 ! IF (ISP.EQ.1) WRITE(6,*) 'EXCLUDED POINT FOR CURRENTS:',IXY,ISEA,IOBP(IXY) 202 END IF 203 END DO 204 END IF 205 206 ! 207 ! 3. initialize fluctuation splitting arrays ( to fit with WWM notations) 208 ! 209 DO IX=1,NX 210 AC(IX) = VQ(IX) 211 AQ(IX) = VQ(IX) 212 C(IX,1) = VLCFLX(IX) 213 C(IX,2) = VLCFLY(IX) 214 END DO 215 ! 216 ! 4. Prepares boundary update 217 ! 218 IF ( FLBPI ) THEN 219 RD1 = DSEC21 ( TBPI0, TIME ) 220 RD2 = DSEC21 ( TBPI0, TBPIN ) 221 ELSE 222 RD1=1. 223 RD2=0. 224 END IF 225 ! 226 ! 4. propagate using the selected scheme 227 ! 228 IF (FSN) THEN Page 5 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 229 CALL W3XYPFSN2 (ISP, C, LCALC, RD1, RD2, DTG, AC, AQ) 230 ELSE IF (FSPSI) THEN 231 CALL W3XYPFSPSI2 (ISP, C, LCALC, RD1, RD2, DTG, AC, AQ) 232 ELSE IF (FSFCT) THEN 233 CALL W3XYPFSFCT2 (ISP, C, LCALC, RD1, RD2, DTG, AC, AQ) 234 ELSE IF (FSNIMP) THEN 235 CALL W3XYPFSNIMP(ISP, C, LCALC, RD1, RD2, DTG, AC, AQ) 236 ENDIF 237 ! 238 DO IX=1,NX 239 ISEA=MAPFS(1,IX) 240 VQ(IX)=AC(IX) 241 ENDDO 242 243 ! 6. Store results in VQ in proper format --------------------------- * 244 ! 245 DO ISEA=1, NSEA 246 IXY = MAPSF(ISEA,3) 247 VQ(IXY) = MAX ( 0. , CG(IK,ISEA)/CLATS(ISEA)*VQ(IXY) ) 248 END DO 249 ! 250 RETURN 251 END SUBROUTINE W3XYPUG ENTRY POINTS Name w3profsmd_mp_w3xypug_ Page 6 Source Listing W3XYPUG 2014-09-16 16:49 Symbol Table w3profsmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References AC Local 162 R(4) 4 1 0 TGT 210,229,231,233,235,240 AQ Local 160 R(4) 4 1 0 TGT 211,229,231,233,235 ATRNX Local 133 R(4) 4 2 1 PTR 133 ATRNY Local 133 R(4) 4 2 1 PTR 133 C Local 154 R(4) 4 2 0 TGT 212,213,229,231,233,235 CCON Local 127 I(4) 4 1 1 PTR 127 CCOS Local 153 R(4) 4 scalar 172,187 CCURX Local 153 R(4) 4 scalar 174,198 CCURY Local 153 R(4) 4 scalar 175,199 CFLXYMAX Local 133 R(4) 4 1 1 PTR 133 CG Local 133 R(4) 4 2 1 PTR 133,186,187,188,247 CLATS Local 124 R(4) 4 1 1 PTR 124,186,187,198,247 CONSTANTS Module 120 120 CSIN Local 153 R(4) 4 scalar 173,188 CX Local 133 R(4) 4 1 1 PTR 133,198 CY Local 133 R(4) 4 1 1 PTR 133,199 DSEC21 Func 122 R(4) 4 scalar 122,219,220 DTCFL Local 124 R(4) 4 scalar PTR 124 DTG Dummy 58 R(4) 4 scalar ARG,IN 229,231,233,235 DTH Local 125 R(4) 4 scalar PTR 125 ECOS Local 126 R(4) 4 1 1 PTR 126,172 ESIN Local 126 R(4) 4 1 1 PTR 126,173 FACX Dummy 58 R(4) 4 scalar ARG,IN 172,174 FACY Dummy 58 R(4) 4 scalar ARG,IN 173,175 FLBPI Local 132 L(4) 4 scalar PTR 132,218 FLCUR Local 134 L(4) 4 scalar PTR 134,191 FLCX Local 125 L(4) 4 scalar PTR 125 FLCY Local 125 L(4) 4 scalar PTR 125 FSFCT Local 129 L(4) 4 scalar PTR 129,232 FSN Local 129 L(4) 4 scalar PTR 129,228 FSNIMP Local 129 L(4) 4 scalar PTR 129,234 FSPSI Local 129 L(4) 4 scalar PTR 129,230 GTYPE Local 129 I(4) 4 scalar PTR 129 I Local 152 I(4) 4 scalar IBI Local 151 I(4) 4 scalar IE Local 152 I(4) 4 scalar IEN Local 126 R(4) 4 2 1 PTR 126 IE_CELL Local 128 I(4) 4 1 1 PTR 128 IK Local 151 I(4) 4 scalar 170,186,187,188,247 IOBP Local 128 I(4) 4 1 1 PTR 128,197 IOBPD Local 128 I(4) 4 2 1 PTR 128 ISEA Local 151 I(4) 4 scalar 184,185,186,187,188,192,193,198,19 9,239,245,246,247 ISP Dummy 58 I(4) 4 scalar ARG,IN 169,170,229,231,233,235 ITH Local 151 I(4) 4 scalar 169,172,173 ITIME Local 133 I(4) 4 scalar PTR 133 IX Local 152 I(4) 4 scalar 209,210,211,212,213,238,239,240 IXY Local 151 I(4) 4 scalar 185,186,187,188,193,197,198,199,24 6,247 IY Local 152 I(4) 4 scalar J Local 152 I(4) 4 scalar Page 7 Source Listing W3XYPUG 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References LCALC Dummy 58 L(4) 4 scalar ARG,IN 229,231,233,235 MAPFS Local 124 I(4) 4 2 1 PTR 124,239 MAPSF Local 124 I(4) 4 2 1 PTR 124,185,193,246 MAX Func 247 scalar 247 MOD Func 169 scalar 169 NK Local 125 I(4) 4 scalar PTR 125 NSEA Local 124 I(4) 4 scalar PTR 124,184,192,245 NTH Local 125 I(4) 4 scalar PTR 125,169,170 NTRI Local 127 I(4) 4 scalar PTR 127 NX Local 124 I(4) 4 scalar PTR 124,144,154,159,160,162,209,238 NY Local 124 I(4) 4 scalar PTR 124,144,159 PFMOVE Local 126 R(4) 4 scalar PTR 126 POS_CELL Local 128 I(4) 4 1 1 PTR 128 RD1 Local 155 R(4) 4 scalar 219,222,229,231,233,235 RD2 Local 155 R(4) 4 scalar 220,223,229,231,233,235 SCHEME Local 146 L(4) 4 scalar SIG Local 126 R(4) 4 1 1 PTR 126 TBPI0 Local 132 I(4) 4 1 1 PTR 132,219,220 TBPIN Local 132 I(4) 4 1 1 PTR 132,220 TIME Local 131 I(4) 4 1 1 PTR 131,219 TRIGP Local 127 I(4) 4 2 1 PTR 127 UNGTYPE Param 129 I(4) 4 scalar 129 VGX Dummy 58 R(4) 4 scalar ARG,IN VGY Dummy 58 R(4) 4 scalar ARG,IN VLCFLX Local 159 R(4) 4 1 0 179,187,198,212 VLCFLY Local 159 R(4) 4 1 0 180,188,199,213 VQ Dummy 58 R(4) 4 1 0 ARG,INOUT 186,210,211,240,247 W3ADATMD Module 133 133 W3GDATMD Module 124 124 W3IDATMD Module 134 134 W3ODATMD Module 132 132 W3TIMEMD Module 122 122 W3WDATMD Module 131 131 W3XYPUG Subr 58 XFR Local 125 R(4) 4 scalar PTR 125 Page 8 Source Listing W3XYPUG 2014-09-16 16:49 w3profsmd.f90 252 !/ ------------------------------------------------------------------- / 253 SUBROUTINE W3CFLUG ( ISEA, NKCFL, FACX, FACY, DT, MAPFS, CFLXYMAX, & 254 VGX, VGY ) 255 !/ 256 !/ +-----------------------------------+ 257 !/ | WAVEWATCH III NOAA/NCEP | 258 !/ | Fabrice Ardhuin | 259 !/ | FORTRAN 90 | 260 !/ | Last update : 01-Mar-2011 | 261 !/ +-----------------------------------+ 262 !/ 263 !/ 01-Mar-2011 : Origination. ( version 3.14 ) 264 !/ 20-Jun-2013 : Computes only up to NKCFL for tests ( version 4.10 ) 265 !/ 266 ! 1. Purpose : 267 ! 268 ! Computes the max CFL number for output purposes 269 ! 270 ! 2. Method : 271 ! 272 ! 3. Parameters : 273 ! 274 ! Parameter list 275 ! ---------------------------------------------------------------- 276 ! ISEA Int. I Index of sea point 277 ! NKCFL Int. I Maximum frequency index 278 ! FACX/Y Real I Factor in propagation velocity. 279 ! ( 1 or 0 * DT / DX ) 280 ! DT Real I Time step. 281 ! MAPFS I.A. I Storage map. 282 ! CFLXYMAX Real Maxmimum CFL for spatial advection 283 ! VGX/Y Real I Speed of grid. 284 ! ---------------------------------------------------------------- 285 ! 286 ! Local variables. 287 ! ---------------------------------------------------------------- 288 ! VCFL0X R.A. Local courant numbers for absolute group vel. 289 ! using local X-grid step. 290 ! VCFL0Y R.A. Id. in Y. 291 ! ---------------------------------------------------------------- 292 ! 293 ! 4. Subroutines used : 294 ! 295 296 ! 5. Called by : 297 ! 298 ! W3WAVE Wave model routine. 299 ! 300 ! 6. Error messages : 301 ! 302 ! None. 303 ! 304 ! 7. Remarks : 305 ! make the interface between the WAVEWATCH and the WWM code. 306 ! 307 ! 8. Structure : 308 ! Page 9 Source Listing W3CFLUG 2014-09-16 16:49 w3profsmd.f90 309 ! 9. Switches : 310 ! 311 ! !/S Enable subroutine tracing. 312 ! 313 ! 10. Source code : 314 !/ ------------------------------------------------------------------- / 315 !/ 316 ! 317 USE CONSTANTS 318 ! 319 USE W3TIMEMD, ONLY: DSEC21 320 ! 321 USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF, DTCFL, CLATS, & 322 FLCX, FLCY, NK, NTH, DTH, XFR, & 323 ECOS, ESIN, SIG, PFMOVE,IEN, INDEX_CELL, & 324 NTRI, TRIGP, CCON , & 325 IE_CELL, POS_CELL, COUNTRI, SI, IOBP, XYB 326 327 USE W3ADATMD, ONLY: CG, CX, CY, ATRNX, ATRNY, ITIME, DW 328 USE W3IDATMD, ONLY: FLCUR 329 330 IMPLICIT NONE 331 !/ ------------------------------------------------------------------- / 332 !/ Parameter list 333 !/ 334 INTEGER, INTENT(IN) :: ISEA, NKCFL, MAPFS(NY*NX) 335 REAL, INTENT(IN) :: FACX, FACY, DT, VGX, VGY 336 REAL, INTENT(INOUT) :: CFLXYMAX 337 !/ 338 !/ ------------------------------------------------------------------- / 339 !/ Local parameters 340 !/ 341 INTEGER :: ITH, IK 342 INTEGER :: IP, IP2, IP3, ISEA2, I, J, IE, IV, I1, I2, I3 343 REAL :: CCOS, CSIN, CCURX, CCURY 344 REAL :: C(NX,2) 345 REAL :: RD1, RD2 346 INTEGER :: COUNTSEACON 347 REAL*8 :: KELEM(3), KTMP(3), LAMBDA(2) 348 REAL*8 :: NM(3), KKSUM, DTMAXEXP 349 !/ 350 !/ Velocities 351 !/ 352 REAL :: VLCFLX, VLCFLY 353 REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 354 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) 355 REAL, PARAMETER :: THR = TINY(1.0) 356 357 !/ ------------------------------------------------------------------- / 358 ! 359 ! 1. Preparations --------------------------------------------------- * 360 ! 1.a Set constants 361 ! 362 363 CFLXYMAX=1E-10 364 IP = MAPSF(ISEA,3) 365 ! Page 10 Source Listing W3CFLUG 2014-09-16 16:49 w3profsmd.f90 366 ! CFL no important on boundary 367 ! 368 IF (IOBP(IP).EQ.1) THEN 369 CCURX = FACX 370 CCURY = FACY 371 ! 372 ! Loop over spectral components 373 ! 374 DO IK=1,NKCFL 375 DO ITH=1,NTH 376 CCOS = FACX * ECOS(ITH) 377 CSIN = FACY * ESIN(ITH) 378 C(:,:)=0. 379 380 ! 381 ! 2. Calculate advection velocities: group speed ---------------- * 382 ! 383 DO I = INDEX_CELL(IP), INDEX_CELL(IP+1)-1 384 IE=IE_CELL(I) ! TRIGP(IE,IV)=IP with IV=POS_CELL(I) 385 DO J=1,3 386 IP2=TRIGP(IE,J) 387 ISEA2=MAPFS(IP2) 388 C(IP2,1) = CCOS * CG(IK,ISEA2) / CLATS(ISEA2) 389 C(IP2,2) = CSIN * CG(IK,ISEA2) 390 IF ( FLCUR ) THEN 391 IF (IOBP(IP2) .EQ. 1) THEN 392 C(IP2,1) = C(IP2,1) + CCURX*CX(ISEA2)/CLATS(ISEA2) 393 C(IP2,2) = C(IP2,2) + CCURY*CY(ISEA2) 394 END IF 395 END IF ! end of ( FLCUR ) 396 END DO 397 END DO 398 ! 399 !3. Calculate K-Values and contour based quantities ... 400 ! 401 KKSUM = 0.d0 402 DO I = INDEX_CELL(IP), INDEX_CELL(IP+1)-1 403 IE=IE_CELL(I) ! TRIGP(IE,IV)=IP 404 IV=POS_CELL(I) 405 I1 = TRIGP(IE,1) 406 I2 = TRIGP(IE,2) 407 I3 = TRIGP(IE,3) 408 LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Advection speed in X direction 409 LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) ! Advection speed in Y direction 410 KELEM(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians 411 KELEM(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) ! K-Values - so called Flux Jacobians 412 KELEM(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) ! K-Values - so called Flux Jacobians 413 414 KTMP = KELEM ! Copy 415 NM = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values 416 KELEM = MAX(0.d0,KTMP) 417 418 KKSUM = KKSUM + KELEM(IV) 419 END DO ! COUNTRI 420 ! 421 DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM) 422 CFLXYMAX = MAX(DBLE(DT)/DTMAXEXP,DBLE(CFLXYMAX)) Page 11 Source Listing W3CFLUG 2014-09-16 16:49 w3profsmd.f90 423 END DO 424 END DO 425 END IF 426 ! 427 RETURN 428 END SUBROUTINE W3CFLUG ENTRY POINTS Name w3profsmd_mp_w3cflug_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ATRNX Local 327 R(4) 4 2 1 PTR 327 ATRNY Local 327 R(4) 4 2 1 PTR 327 C Local 344 R(4) 4 2 0 378,388,389,392,393,408,409 CCON Local 324 I(4) 4 1 1 PTR 324 CCOS Local 343 R(4) 4 scalar 376,388 CCURX Local 343 R(4) 4 scalar 369,392 CCURY Local 343 R(4) 4 scalar 370,393 CFLXYMAX Dummy 253 R(4) 4 scalar ARG,INOUT 363,422 CG Local 327 R(4) 4 2 1 PTR 327,388,389 CLATS Local 321 R(4) 4 1 1 PTR 321,388,392 CONSTANTS Module 317 317 COUNTRI Local 325 I(4) 4 scalar PTR 325 COUNTSEACON Local 346 I(4) 4 scalar CSIN Local 343 R(4) 4 scalar 377,389 CX Local 327 R(4) 4 1 1 PTR 327,392 CY Local 327 R(4) 4 1 1 PTR 327,393 DBLE Func 421 scalar 421,422 DSEC21 Func 319 R(4) 4 scalar 319 DT Dummy 253 R(4) 4 scalar ARG,IN 422 DTCFL Local 321 R(4) 4 scalar PTR 321 DTH Local 322 R(4) 4 scalar PTR 322 DTMAXEXP Local 348 R(8) 8 scalar 421,422 DW Local 327 R(4) 4 1 1 PTR 327 ECOS Local 323 R(4) 4 1 1 PTR 323,376 ESIN Local 323 R(4) 4 1 1 PTR 323,377 FACX Dummy 253 R(4) 4 scalar ARG,IN 369,376 FACY Dummy 253 R(4) 4 scalar ARG,IN 370,377 FLCUR Local 328 L(4) 4 scalar PTR 328,390 FLCX Local 322 L(4) 4 scalar PTR 322 FLCY Local 322 L(4) 4 scalar PTR 322 I Local 342 I(4) 4 scalar 383,384,402,403,404 I1 Local 342 I(4) 4 scalar 405,408,409 I2 Local 342 I(4) 4 scalar 406,408,409 I3 Local 342 I(4) 4 scalar 407,408,409 IE Local 342 I(4) 4 scalar 384,386,403,405,406,407,410,411,41 2 IEN Local 323 R(4) 4 2 1 PTR 323,410,411,412 IE_CELL Local 325 I(4) 4 1 1 PTR 325,384,403 Page 12 Source Listing W3CFLUG 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References IK Local 341 I(4) 4 scalar 374,388,389 INDEX_CELL Local 323 I(4) 4 1 1 PTR 323,383,402 IOBP Local 325 I(4) 4 1 1 PTR 325,368,391 IP Local 342 I(4) 4 scalar 364,368,383,402,421 IP2 Local 342 I(4) 4 scalar 386,387,388,389,391,392,393 IP3 Local 342 I(4) 4 scalar ISEA Dummy 253 I(4) 4 scalar ARG,IN 364 ISEA2 Local 342 I(4) 4 scalar 387,388,389,392,393 ITH Local 341 I(4) 4 scalar 375,376,377 ITIME Local 327 I(4) 4 scalar PTR 327 IV Local 342 I(4) 4 scalar 404,418 J Local 342 I(4) 4 scalar 385,386 KELEM Local 347 R(8) 8 1 3 410,411,412,414,416,418 KKSUM Local 348 R(8) 8 scalar 401,418,421 KTMP Local 347 R(8) 8 1 3 414,415,416 LAMBDA Local 347 R(8) 8 1 2 408,409,410,411,412 MAPFS Dummy 253 I(4) 4 1 0 ARG,IN 387 MAPSF Local 321 I(4) 4 2 1 PTR 321,364 MAX Func 416 scalar 416,421,422 MIN Func 415 scalar 415 NK Local 322 I(4) 4 scalar PTR 322 NKCFL Dummy 253 I(4) 4 scalar ARG,IN 374 NM Local 348 R(8) 8 1 3 415 NSEA Local 321 I(4) 4 scalar PTR 321 NTH Local 322 I(4) 4 scalar PTR 322,375 NTRI Local 324 I(4) 4 scalar PTR 324 NX Local 321 I(4) 4 scalar PTR 321,334,344 NY Local 321 I(4) 4 scalar PTR 321,334 ONESIXTH Param 353 R(8) 8 scalar 408,409 PFMOVE Local 323 R(4) 4 scalar PTR 323 POS_CELL Local 325 I(4) 4 1 1 PTR 325,404 RD1 Local 345 R(4) 4 scalar RD2 Local 345 R(4) 4 scalar SI Local 325 R(4) 4 1 1 PTR 325,421 SIG Local 323 R(4) 4 1 1 PTR 323 SUM Func 415 scalar 415 THR Param 355 R(4) 4 scalar THR8 Param 354 R(8) 8 scalar 415 TINY Func 354 scalar 354,355 TRIGP Local 324 I(4) 4 2 1 PTR 324,386,405,406,407 VGX Dummy 254 R(4) 4 scalar ARG,IN VGY Dummy 254 R(4) 4 scalar ARG,IN VLCFLX Local 352 R(4) 4 scalar VLCFLY Local 352 R(4) 4 scalar W3ADATMD Module 327 327 W3CFLUG Subr 253 W3GDATMD Module 321 321 W3IDATMD Module 328 328 W3TIMEMD Module 319 319 XFR Local 322 R(4) 4 scalar PTR 322 XYB Local 325 R(8) 8 2 1 PTR 325 Page 13 Source Listing W3CFLUG 2014-09-16 16:49 w3profsmd.f90 429 !/ ------------------------------------------------------------------- / 430 431 SUBROUTINE W3XYPFSN2 ( ISP, C, LCALC, RD10, RD20, DT, AC, AQ) 432 433 !/ 434 !/ 435 !/ +-----------------------------------+ 436 !/ | WWIII Version of the WWM FS Code | 437 !/ | by Aron Roland | 438 !/ | and Fabrice Ardhuin | 439 !/ | for use in WWIII | 440 !/ | GPL License | 441 !/ | Last update : 03-Nov-2011 | 442 !/ +-----------------------------------+ 443 !/ 444 !/ 19-Dec-2007 : Origination. ( version 3.13 ) 445 !/ 25-Aug-2011 : Change of method for IOBPD ( version 4.04 ) 446 !/ 03-Nov-2011 : Addition of shoreline reflection ( version 4.04 ) 447 !/ 448 !/ 449 ! 1. Purpose : 450 ! Advection of a scalar in a arbitary velocity field on unstructured meshes 451 ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space 452 ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall 453 ! 454 ! 2. Method : 455 ! 456 ! 3. Parameters : 457 ! 458 ! Parameter list 459 ! ---------------------------------------------------------------- 460 ! ---------------------------------------------------------------- 461 ! 462 ! 4. Subroutines used : 463 ! 464 ! STRACE Subroutine tracing (!/S switch) 465 ! 466 ! 5. Called by : 467 ! 468 ! W3XYPUG Routine for advection on unstructured grid 469 ! 470 ! 6. Error messages : 471 ! 472 ! None. 473 ! 474 ! 7. Remarks : 475 ! 476 ! 8. Structure : 477 ! 478 ! See source code. 479 ! 480 ! 9. Switches : 481 ! 482 ! !/S Enable subroutine tracing. 483 ! 484 ! 10. Source code : 485 ! Page 14 Source Listing W3XYPFSN2 2014-09-16 16:49 w3profsmd.f90 486 !/ ------------------------------------------------------------------- / 487 !/ 488 USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & 489 IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, XYB 490 USE W3WDATMD, ONLY: TIME 491 USE W3ADATMD, ONLY: CG, ITER 492 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN 493 USE W3TIMEMD, ONLY: DSEC21 494 IMPLICIT NONE 495 496 INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction 497 REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the g 497 iven vel 498 REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, 499 REAL, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection 500 REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions 501 LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step 502 REAL, INTENT(INOUT) :: AQ(:) 503 !/ 504 !/ ------------------------------------------------------------------- / 505 !/ Parameter list 506 !/ 507 !/ 508 !/ ------------------------------------------------------------------- / 509 !/ Local parameters 510 !/ 511 512 REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 513 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) 514 REAL, PARAMETER :: THR = TINY(1.0) 515 !/ 516 !/ ------------------------------------------------------------------- / 517 !/ 518 ! 519 ! local integer 520 ! 521 INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK 522 INTEGER :: IBI, NI(3) 523 ! 524 ! local real 525 ! 526 REAL :: RD1, RD2 527 !: 528 ! local double 529 ! 530 REAL*8 :: IEN1(2), IEN2(2), IEN3(2) 531 REAL*8 :: U1, U2, U3 532 REAL*8 :: UTILDE 533 REAL*8 :: SUMTHETA 534 REAL*8 :: FL1, FL2, FL3 535 REAL*8 :: FT, CFLXY 536 REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 537 REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 538 REAL*8 :: DTSI(NX), U(NX) 539 REAL*8 :: DTMAXGL, DTMAXEXP, REST 540 REAL*8 :: LAMBDA(2), KTMP(3) 541 REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) Page 15 Source Listing W3XYPFSN2 2014-09-16 16:49 w3profsmd.f90 542 REAL*8 :: KKSUM(NX), ST(NX) 543 REAL*8 :: NM(NTRI) 544 545 546 ! 1. initialisation 547 548 ITH = 1 + MOD(ISP-1,NTH) 549 IK = 1 + (ISP-1)/NTH 550 DTMAXGL = DBLE(10.E10) 551 552 553 ! IF (SUM(AC) .GT. 0. .OR. SUM(AQ) .GT. 0) WRITE(*,*) SUM(AC), SUM(AQ) 554 555 ! 556 !2 Propagation 557 !2.a Calculate K-Values and contour based quantities ... 558 ! 559 DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... 560 I1 = TRIGP(IE,1) ! Index of the Element Nodes (TRIGP) 561 I2 = TRIGP(IE,2) 562 I3 = TRIGP(IE,3) 563 LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction 564 LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) 565 KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians 566 KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) 567 KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) 568 ! 569 KTMP = KELEM(:,IE) ! Copy 570 NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values 571 KELEM(:,IE) = MAX(0.d0,KTMP) 572 FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration 573 FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) 574 FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) 575 FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) 576 FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) 577 FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) 578 FL111 = 2.d0*FL11+FL12 579 FL112 = 2.d0*FL12+FL11 580 FL211 = 2.d0*FL21+FL22 581 FL212 = 2.d0*FL22+FL21 582 FL311 = 2.d0*FL31+FL32 583 FL312 = 2.d0*FL32+FL31 584 FLALL(1,IE) = (FL311 + FL212) * ONESIXTH + KELEM(1,IE) 585 FLALL(2,IE) = (FL111 + FL312) * ONESIXTH + KELEM(2,IE) 586 FLALL(3,IE) = (FL211 + FL112) * ONESIXTH + KELEM(3,IE) 587 ! IF (I1.EQ.1.OR.I2.EQ.1.OR.I3.EQ.1) WRITE(6,*) 'TEST N1 :',IK,ITH,IP,IE,KELEM(:,IE),'##',LAMBDA 588 END DO ! NTRI 589 590 IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow f 590 ield and 591 KKSUM = 0.d0 592 DO IE = 1, NTRI 593 NI = TRIGP(IE,:) 594 KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) 595 END DO ! IE 596 DO IP = 1, NX 597 DTMAXEXP = 1E10 ! initialize to large number Page 16 Source Listing W3XYPFSN2 2014-09-16 16:49 w3profsmd.f90 598 ! Does take into account boundary points in CFL calculation 599 IF (IOBP(IP) .NE. 0) CYCLE 600 DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)) 601 DTMAXGL = MIN( DTMAXGL, DTMAXEXP) 602 END DO ! IP 603 ! 604 CFLXY = DBLE(DT)/DTMAXGL 605 REST = ABS(MOD(CFLXY,1.0d0)) 606 IF (REST .LT. THR8) THEN 607 ITER(IK,ITH) = ABS(NINT(CFLXY)) 608 ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN 609 ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 610 ELSE 611 ITER(IK,ITH) = ABS(NINT(CFLXY)) 612 END IF 613 END IF ! LCALC 614 615 DO IP = 1, NX 616 DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. 617 END DO 618 619 DO IT = 1, ITER(IK,ITH) 620 U = DBLE(AC) 621 ST = 0.d0 622 DO IE = 1, NTRI 623 NI = TRIGP(IE,:) 624 UTILDE = NM(IE) * (DOT_PRODUCT(FLALL(:,IE),U(NI))) 625 ST(NI) = ST(NI) + KELEM(:,IE) * (U(NI) - UTILDE) ! the 2nd term are the theta values of each node ... 626 END DO ! IE 627 628 DO IP = 1, NX 629 ! 630 ! IOBPD=0 : waves coming from land 631 ! IOBPDR=1 : waves coming from the coast 632 ! 633 U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP))*DBLE(IOBPD(ITH,IP)) 634 END DO 635 AC = REAL(U) 636 ! 637 ! 5 Update boundaries ... would be better to omit any if clause in this loop ... 638 ! a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI 639 ! 640 IF ( FLBPI ) THEN 641 RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) 642 RD2=RD20 643 IF ( RD2 .GT. 0.001 ) THEN 644 RD2 = MIN(1.,MAX(0.,RD1/RD2)) 645 RD1 = 1. - RD2 646 ELSE 647 RD1 = 0. 648 RD2 = 1. 649 END IF 650 ! 651 ! NB: this treatment of the open boundary (time interpolation) is different from 652 ! the constant boundary in the structured grids ... which restores the boundary 653 ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) 654 ! Why this difference ? Page 17 Source Listing W3XYPFSN2 2014-09-16 16:49 w3profsmd.f90 655 ! 656 DO IBI=1, NBI 657 IP = MAPSF(ISBPI(IBI),1) 658 AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & 659 / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) 660 END DO 661 END IF 662 END DO ! IT 663 ! CALL EXTCDE ( 99 ) 664 !/ 665 !/ End of W3XYPFSN ----------------------------------------------------- / 666 !/ 667 END SUBROUTINE W3XYPFSN2 ENTRY POINTS Name w3profsmd_mp_w3xypfsn2_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 605 scalar 605,607,609,611 AC Dummy 431 R(4) 4 1 1 ARG,INOUT 620,635,658 AQ Dummy 431 R(4) 4 1 1 ARG,INOUT BBPI0 Local 492 R(4) 4 2 1 PTR 492,658 BBPIN Local 492 R(4) 4 2 1 PTR 492,658 C Dummy 431 R(4) 4 2 1 ARG,IN 563,564,572,573,574,575,576,577 CCON Local 488 I(4) 4 1 1 PTR 488 CFLXY Local 535 R(8) 8 scalar 604,605,607,609,611 CG Local 491 R(4) 4 2 1 PTR 491,659 CLATS Local 489 R(4) 4 1 1 PTR 489,659 DBLE Func 550 scalar 550,600,604,616,620,633 DOT_PRODUCT Func 624 scalar 624 DSEC21 Func 493 R(4) 4 scalar 493 DT Dummy 431 R(4) 4 scalar ARG,IN 604,616,641 DTMAXEXP Local 539 R(8) 8 scalar 597,600,601 DTMAXGL Local 539 R(8) 8 scalar 550,601,604 DTSI Local 538 R(8) 8 1 0 616,633 FL1 Local 534 R(8) 8 scalar FL11 Local 536 R(8) 8 scalar 572,578,579 FL111 Local 537 R(8) 8 scalar 578,585 FL112 Local 537 R(8) 8 scalar 579,586 FL12 Local 536 R(8) 8 scalar 573,578,579 FL2 Local 534 R(8) 8 scalar FL21 Local 536 R(8) 8 scalar 574,580,581 FL211 Local 537 R(8) 8 scalar 580,586 FL212 Local 537 R(8) 8 scalar 581,584 FL22 Local 536 R(8) 8 scalar 575,580,581 FL3 Local 534 R(8) 8 scalar FL31 Local 536 R(8) 8 scalar 576,582,583 FL311 Local 537 R(8) 8 scalar 582,584 FL312 Local 537 R(8) 8 scalar 583,585 Page 18 Source Listing W3XYPFSN2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References FL32 Local 536 R(8) 8 scalar 577,582,583 FLALL Local 541 R(8) 8 2 0 584,585,586,624 FLBPI Local 492 L(4) 4 scalar PTR 492,640 FT Local 535 R(8) 8 scalar I Local 521 I(4) 4 scalar I1 Local 521 I(4) 4 scalar 560,563,564,575,576 I2 Local 521 I(4) 4 scalar 561,563,564,572,577 I3 Local 521 I(4) 4 scalar 562,563,564,573,574 IBI Local 522 I(4) 4 scalar 656,657,658,659 IE Local 521 I(4) 4 scalar 559,560,561,562,565,566,567,569,57 0,571,572,573,574,575,576,577,584, 585,586,592,593,594,622,623,624,62 5 IEN Local 489 R(4) 4 2 1 PTR 489,565,566,567,572,573,574,575,57 6,577 IEN1 Local 530 R(8) 8 1 2 IEN2 Local 530 R(8) 8 1 2 IEN3 Local 530 R(8) 8 1 2 IE_CELL Local 488 I(4) 4 1 1 PTR 488 IK Local 521 I(4) 4 scalar 549,607,609,611,616,619,641,659 IOBP Local 489 I(4) 4 1 1 PTR 489,599 IOBPD Local 489 I(4) 4 2 1 PTR 489,633 IP Local 521 I(4) 4 scalar 596,599,600,615,616,628,633,657,65 8 ISBPI Local 492 I(4) 4 1 1 PTR 492,657,659 ISP Dummy 431 I(4) 4 scalar ARG,IN 548,549,658 IT Local 521 I(4) 4 scalar 619,641 ITER Local 491 I(4) 4 2 1 PTR 491,607,609,611,616,619,641 ITH Local 521 I(4) 4 scalar 548,607,609,611,616,619,633,641 J Local 521 I(4) 4 scalar KELEM Local 541 R(8) 8 2 0 565,566,567,569,571,584,585,586,59 4,625 KKSUM Local 542 R(8) 8 1 0 591,594,600 KTMP Local 540 R(8) 8 1 3 569,570,571 LAMBDA Local 540 R(8) 8 1 2 563,564,565,566,567 LCALC Dummy 431 L(4) 4 scalar ARG,IN 590 MAPSF Local 489 I(4) 4 2 1 PTR 489,657 MAX Func 571 scalar 571,600,633,644 MIN Func 570 scalar 570,601,644 MOD Func 548 scalar 548,605 NBI Local 492 I(4) 4 scalar PTR 492,656 NDSE Local 492 I(4) 4 scalar PTR 492 NDST Local 492 I(4) 4 scalar PTR 492 NI Local 522 I(4) 4 1 3 593,594,623,624,625 NINT Func 607 scalar 607,609,611 NK Local 488 I(4) 4 scalar PTR 488 NM Local 543 R(8) 8 1 0 570,624 NTH Local 488 I(4) 4 scalar PTR 488,548,549 NTRI Local 488 I(4) 4 scalar PTR 488,541,543,559,592,622 NX Local 488 I(4) 4 scalar PTR 488,538,542,596,615,628 ONESIXTH Param 512 R(8) 8 scalar 563,564,584,585,586 POS Local 521 I(4) 4 scalar POS_CELL Local 488 I(4) 4 1 1 PTR 488 RD1 Local 526 R(4) 4 scalar 641,644,645,647,658 RD10 Dummy 431 R(4) 4 scalar ARG,IN 641 Page 19 Source Listing W3XYPFSN2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References RD2 Local 526 R(4) 4 scalar 642,643,644,645,648,658 RD20 Dummy 431 R(4) 4 scalar ARG,IN 642 REAL Func 635 scalar 635,641 REST Local 539 R(8) 8 scalar 605,606,608 SI Local 488 R(4) 4 1 1 PTR 488,600,616 ST Local 542 R(8) 8 1 0 621,625,633 SUM Func 570 scalar 570 SUMTHETA Local 533 R(8) 8 scalar TBPI0 Local 492 I(4) 4 1 1 PTR 492 TBPIN Local 492 I(4) 4 1 1 PTR 492 THR Param 514 R(4) 4 scalar THR8 Param 513 R(8) 8 scalar 570,606,608 TIME Local 490 I(4) 4 1 1 PTR 490 TINY Func 513 scalar 513,514 TRIGP Local 489 I(4) 4 2 1 PTR 489,560,561,562,593,623 U Local 538 R(8) 8 1 0 620,624,625,633,635 U1 Local 531 R(8) 8 scalar U2 Local 531 R(8) 8 scalar U3 Local 531 R(8) 8 scalar UTILDE Local 532 R(8) 8 scalar 624,625 W3ADATMD Module 491 491 W3GDATMD Module 488 488 W3ODATMD Module 492 492 W3TIMEMD Module 493 493 W3WDATMD Module 490 490 W3XYPFSN2 Subr 431 229 XYB Local 489 R(8) 8 2 1 PTR 489 Page 20 Source Listing W3XYPFSN2 2014-09-16 16:49 w3profsmd.f90 668 669 !/ ------------------------------------------------------------------- / 670 SUBROUTINE W3XYPFSPSI2 ( ISP, C, LCALC, RD10, RD20, DT, AC, AQ) 671 672 !/ 673 !/ 674 !/ +-----------------------------------+ 675 !/ | WWIII Version of the WWM FS Code | 676 !/ | by Aron Roland | 677 !/ | for use in WWIII | 678 !/ | GPL License | 679 !/ | Last update : 19-Dec-2007 | 680 !/ +-----------------------------------+ 681 !/ 682 ! 1. Purpose : 683 ! Advection of a scalar in a arbitary velocity field on unstructured meshes 684 ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space 685 ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall 686 ! 687 ! 2. Method : 688 ! 689 ! 3. Parameters : 690 ! 691 ! Parameter list 692 ! ---------------------------------------------------------------- 693 ! ---------------------------------------------------------------- 694 ! 695 ! 4. Subroutines used : 696 ! 697 ! STRACE Subroutine tracing (!/S switch) 698 ! 699 ! 5. Called by : 700 ! 701 ! W3XYPUG Routine for advection on unstructured grid 702 ! 703 ! 6. Error messages : 704 ! 705 ! None. 706 ! 707 ! 7. Remarks : 708 ! 709 ! 8. Structure : 710 ! 711 ! See source code. 712 ! 713 ! 9. Switches : 714 ! 715 ! !/S Enable subroutine tracing. 716 ! 717 ! 10. Source code : 718 ! 719 !/ ------------------------------------------------------------------- / 720 !/ 721 USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & 722 IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, NNZ 723 USE W3WDATMD, ONLY: TIME 724 USE W3ADATMD, ONLY: CG, ITER Page 21 Source Listing W3XYPFSPSI2 2014-09-16 16:49 w3profsmd.f90 725 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN 726 USE W3TIMEMD, ONLY: DSEC21 727 IMPLICIT NONE 728 729 INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction 730 REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the g 730 iven vel 731 REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, 732 REAL, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection 733 REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions 734 LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step 735 REAL, INTENT(INOUT) :: AQ(:) 736 !/ 737 !/ ------------------------------------------------------------------- / 738 !/ Parameter list 739 !/ 740 !/ 741 !/ ------------------------------------------------------------------- / 742 !/ Local parameters 743 !/ 744 745 REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 746 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) 747 REAL, PARAMETER :: THR = TINY(1.0) 748 !/ 749 !/ ------------------------------------------------------------------- / 750 !/ 751 ! 752 ! local integer 753 ! 754 INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK 755 INTEGER :: IBI, NI(3) 756 ! 757 ! local real 758 ! 759 REAL :: RD1, RD2 760 !: 761 ! local double 762 ! 763 REAL*8 :: IEN1(2), IEN2(2), IEN3(2) 764 REAL*8 :: U1, U2, U3 765 REAL*8 :: UTILDE 766 REAL*8 :: SUMTHETA 767 REAL*8 :: FL1, FL2, FL3 768 REAL*8 :: FT, CFLXY 769 REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 770 REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 771 REAL*8 :: DTSI(NX), U(NX) 772 REAL*8 :: DTMAXGL, DTMAXEXP, REST 773 REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) 774 REAL*8 :: THETA_L(3), BET1(3), BETAHAT(3) 775 REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) 776 REAL*8 :: KKSUM(NX), ST(NX) 777 REAL*8 :: NM(NTRI) 778 779 780 ! 1. initialisation Page 22 Source Listing W3XYPFSPSI2 2014-09-16 16:49 w3profsmd.f90 781 782 ITH = 1 + MOD(ISP-1,NTH) 783 IK = 1 + (ISP-1)/NTH 784 DTMAXGL = DBLE(10.E10) 785 786 ! 787 !2 Propagation 788 !2.a Calculate K-Values and contour based quantities ... 789 ! 790 DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... 791 I1 = TRIGP(IE,1) ! Index of the Element Nodes (TRIGP) 792 I2 = TRIGP(IE,2) 793 I3 = TRIGP(IE,3) 794 LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction 795 LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) 796 KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians 797 KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) 798 KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) 799 KTMP = KELEM(:,IE) ! Copy 800 NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values 801 KELEM(:,IE) = MAX(0.d0,KTMP) 802 FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration 803 FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) 804 FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) 805 FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) 806 FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) 807 FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) 808 FL111 = 2.d0*FL11+FL12 809 FL112 = 2.d0*FL12+FL11 810 FL211 = 2.d0*FL21+FL22 811 FL212 = 2.d0*FL22+FL21 812 FL311 = 2.d0*FL31+FL32 813 FL312 = 2.d0*FL32+FL31 814 FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) 815 FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) 816 FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) 817 END DO ! NTRI 818 819 IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow 819 field a 820 KKSUM = 0.d0 821 DO IE = 1, NTRI 822 NI = TRIGP(IE,:) 823 KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) 824 END DO ! IE 825 DO IP = 1, NX 826 ! DTMAXEXP = MAX( ABS(DBLE(IOBP(IP))*DBLE(10.E10)),SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*DBLE(IOBPD(ITH,IP)))) ! 826 This cor 827 DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)) 828 DTMAXGL = MIN( DTMAXGL, DTMAXEXP) 829 END DO ! IP 830 CFLXY = DBLE(DT)/DTMAXGL 831 REST = ABS(MOD(CFLXY,1.0d0)) 832 IF (REST .LT. THR8) THEN 833 ITER(IK,ITH) = ABS(NINT(CFLXY)) 834 ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN 835 ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 Page 23 Source Listing W3XYPFSPSI2 2014-09-16 16:49 w3profsmd.f90 836 ELSE 837 ITER(IK,ITH) = ABS(NINT(CFLXY)) 838 END IF 839 END IF ! LCALC 840 841 DO IP = 1, NX 842 DTSI(IP) = DBLE(DT)/DBLE(ITER(IK,ITH))/SI(IP) ! Some precalculations for the time integration. 843 END DO 844 845 DO IT = 1, ITER(IK,ITH) 846 U = DBLE(AC) 847 848 ST = 0.d0 849 850 DO IE = 1, NTRI 851 NI = TRIGP(IE,:) 852 FT =-ONESIXTH*DOT_PRODUCT(U(NI),FLALL(:,IE)) 853 UTILDE = NM(IE) * ( DOT_PRODUCT(KELEM(:,IE),U(NI)) - FT ) 854 THETA_L(:) = KELEM(:,IE) * (U(NI) - UTILDE) 855 IF (ABS(FT) .GT. 0.0d0) THEN 856 BET1(:) = THETA_L(:)/FT 857 IF (ANY( BET1 .LT. 0.0d0) ) THEN 858 BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) 859 BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) 860 BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) 861 BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) 862 BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) 863 BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) 864 THETA_L(:) = FT * BET1 865 END IF 866 ELSE 867 THETA_L(:) = 0.d0 868 END IF 869 ST(NI) = ST(NI) + THETA_L ! the 2nd term are the theta values of each node ... 870 END DO 871 872 ! DO IP = 1, NX 873 ! U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP))*DBLE(IOBPD(ITH,IP)) ! Add dry/wet flag ... 874 ! END DO 875 876 DO IP = 1, NX 877 U(IP) = MAX(0.d0,U(IP)-DTSI(IP)*ST(IP))*DBLE(IOBPD(ITH,IP)) ! Add dry/wet flag ... 878 END DO 879 AC = REAL(U) 880 ! 881 ! 5 Update boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... 882 ! 883 IF ( FLBPI ) THEN 884 RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) 885 RD2=RD20 886 IF ( RD2 .GT. 0.001 ) THEN 887 RD2 = MIN(1.,MAX(0.,RD1/RD2)) 888 RD1 = 1. - RD2 889 ELSE 890 RD1 = 0. 891 RD2 = 1. 892 END IF Page 24 Source Listing W3XYPFSPSI2 2014-09-16 16:49 w3profsmd.f90 893 ! 894 ! NB: this treatment of the open boundary (time interpolation) is different from 895 ! the constant boundary in the structured grids ... which restores the boundary 896 ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) 897 ! Why this difference ? 898 ! 899 DO IBI=1, NBI 900 IP = MAPSF(ISBPI(IBI),1) 901 AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & 902 / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) 903 ENDDO 904 END IF 905 ! WRITE(6,*) 'ITER:',IK, ITH, LCALC, ITER(IK,ITH),IT,RD10,RD20,RD1,RD2 906 END DO ! IT 907 ! CALL EXTCDE ( 99 ) 908 !/ 909 !/ End of W3XYPFSN ----------------------------------------------------- / 910 !/ 911 END SUBROUTINE W3XYPFSPSI2 ENTRY POINTS Name w3profsmd_mp_w3xypfspsi2_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 831 scalar 831,833,835,837,855 AC Dummy 670 R(4) 4 1 1 ARG,INOUT 846,879,901 ANY Func 857 scalar 857 AQ Dummy 670 R(4) 4 1 1 ARG,INOUT BBPI0 Local 725 R(4) 4 2 1 PTR 725,901 BBPIN Local 725 R(4) 4 2 1 PTR 725,901 BET1 Local 774 R(8) 8 1 3 856,857,858,859,860,861,862,863,86 4 BETAHAT Local 774 R(8) 8 1 3 858,859,860,861,862,863 C Dummy 670 R(4) 4 2 1 ARG,IN 794,795,802,803,804,805,806,807 CCON Local 721 I(4) 4 1 1 PTR 721 CFLXY Local 768 R(8) 8 scalar 830,831,833,835,837 CG Local 724 R(4) 4 2 1 PTR 724,902 CLATS Local 722 R(4) 4 1 1 PTR 722,902 DBLE Func 784 scalar 784,827,830,842,846,877 DOT_PRODUCT Func 852 scalar 852,853 DSEC21 Func 726 R(4) 4 scalar 726 DT Dummy 670 R(4) 4 scalar ARG,IN 830,842,884 DTMAXEXP Local 772 R(8) 8 scalar 827,828 DTMAXGL Local 772 R(8) 8 scalar 784,828,830 DTSI Local 771 R(8) 8 1 0 842,877 FL1 Local 767 R(8) 8 scalar FL11 Local 769 R(8) 8 scalar 802,808,809 FL111 Local 770 R(8) 8 scalar 808,815 FL112 Local 770 R(8) 8 scalar 809,816 Page 25 Source Listing W3XYPFSPSI2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References FL12 Local 769 R(8) 8 scalar 803,808,809 FL2 Local 767 R(8) 8 scalar FL21 Local 769 R(8) 8 scalar 804,810,811 FL211 Local 770 R(8) 8 scalar 810,816 FL212 Local 770 R(8) 8 scalar 811,814 FL22 Local 769 R(8) 8 scalar 805,810,811 FL3 Local 767 R(8) 8 scalar FL31 Local 769 R(8) 8 scalar 806,812,813 FL311 Local 770 R(8) 8 scalar 812,814 FL312 Local 770 R(8) 8 scalar 813,815 FL32 Local 769 R(8) 8 scalar 807,812,813 FLALL Local 775 R(8) 8 2 0 814,815,816,852 FLBPI Local 725 L(4) 4 scalar PTR 725,883 FT Local 768 R(8) 8 scalar 852,853,855,856,864 I Local 754 I(4) 4 scalar I1 Local 754 I(4) 4 scalar 791,794,795,805,806 I2 Local 754 I(4) 4 scalar 792,794,795,802,807 I3 Local 754 I(4) 4 scalar 793,794,795,803,804 IBI Local 755 I(4) 4 scalar 899,900,901,902 IE Local 754 I(4) 4 scalar 790,791,792,793,796,797,798,799,80 0,801,802,803,804,805,806,807,814, 815,816,821,822,823,850,851,852,85 3,854 IEN Local 722 R(4) 4 2 1 PTR 722,796,797,798,802,803,804,805,80 6,807 IEN1 Local 763 R(8) 8 1 2 IEN2 Local 763 R(8) 8 1 2 IEN3 Local 763 R(8) 8 1 2 IE_CELL Local 721 I(4) 4 1 1 PTR 721 IK Local 754 I(4) 4 scalar 783,833,835,837,842,845,884,902 IOBP Local 722 I(4) 4 1 1 PTR 722 IOBPD Local 722 I(4) 4 2 1 PTR 722,877 IP Local 754 I(4) 4 scalar 825,827,841,842,876,877,900,901 ISBPI Local 725 I(4) 4 1 1 PTR 725,900,902 ISP Dummy 670 I(4) 4 scalar ARG,IN 782,783,901 IT Local 754 I(4) 4 scalar 845,884 ITER Local 724 I(4) 4 2 1 PTR 724,833,835,837,842,845,884 ITH Local 754 I(4) 4 scalar 782,833,835,837,842,845,877,884 J Local 754 I(4) 4 scalar KELEM Local 775 R(8) 8 2 0 796,797,798,799,801,823,853,854 KKSUM Local 776 R(8) 8 1 0 820,823,827 KTMP Local 773 R(8) 8 1 3 799,800,801 LAMBDA Local 773 R(8) 8 1 2 794,795,796,797,798 LCALC Dummy 670 L(4) 4 scalar ARG,IN 819 MAPSF Local 722 I(4) 4 2 1 PTR 722,900 MAX Func 801 scalar 801,827,861,862,863,877,887 MIN Func 800 scalar 800,828,861,862,863,887 MOD Func 782 scalar 782,831 NBI Local 725 I(4) 4 scalar PTR 725,899 NDSE Local 725 I(4) 4 scalar PTR 725 NDST Local 725 I(4) 4 scalar PTR 725 NI Local 755 I(4) 4 1 3 822,823,851,852,853,854,869 NINT Func 833 scalar 833,835,837 NK Local 721 I(4) 4 scalar PTR 721 NM Local 777 R(8) 8 1 0 800,853 Page 26 Source Listing W3XYPFSPSI2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NNZ Local 722 I(4) 4 scalar PTR 722 NTH Local 721 I(4) 4 scalar PTR 721,782,783 NTRI Local 721 I(4) 4 scalar PTR 721,775,777,790,821,850 NX Local 721 I(4) 4 scalar PTR 721,771,776,825,841,876 ONESIXTH Param 745 R(8) 8 scalar 794,795,852 POS Local 754 I(4) 4 scalar POS_CELL Local 721 I(4) 4 1 1 PTR 721 RD1 Local 759 R(4) 4 scalar 884,887,888,890,901 RD10 Dummy 670 R(4) 4 scalar ARG,IN 884 RD2 Local 759 R(4) 4 scalar 885,886,887,888,891,901 RD20 Dummy 670 R(4) 4 scalar ARG,IN 885 REAL Func 879 scalar 879,884 REST Local 772 R(8) 8 scalar 831,832,834 SI Local 721 R(4) 4 1 1 PTR 721,827,842 ST Local 776 R(8) 8 1 0 848,869,877 SUM Func 800 scalar 800 SUMTHETA Local 766 R(8) 8 scalar TBPI0 Local 725 I(4) 4 1 1 PTR 725 TBPIN Local 725 I(4) 4 1 1 PTR 725 THETA_L Local 774 R(8) 8 1 3 854,856,864,867,869 THR Param 747 R(4) 4 scalar THR8 Param 746 R(8) 8 scalar 800,832,834 TIME Local 723 I(4) 4 1 1 PTR 723 TINY Func 746 scalar 746,747 TMP Local 773 R(8) 8 1 3 TRIGP Local 722 I(4) 4 2 1 PTR 722,791,792,793,822,851 U Local 771 R(8) 8 1 0 846,852,853,854,877,879 U1 Local 764 R(8) 8 scalar U2 Local 764 R(8) 8 scalar U3 Local 764 R(8) 8 scalar UTILDE Local 765 R(8) 8 scalar 853,854 W3ADATMD Module 724 724 W3GDATMD Module 721 721 W3ODATMD Module 725 725 W3TIMEMD Module 726 726 W3WDATMD Module 723 723 W3XYPFSPSI2 Subr 670 231 Page 27 Source Listing W3XYPFSPSI2 2014-09-16 16:49 w3profsmd.f90 912 913 !/ ------------------------------------------------------------------- / 914 SUBROUTINE W3XYPFSNIMP ( ISP, C, LCALC, RD10, RD20, DT, AC, AQ) 915 916 !/ 917 !/ 918 !/ +-----------------------------------+ 919 !/ | WWIII Version of the WWM FS Code | 920 !/ | by Aron Roland | 921 !/ | for use in WWIII | 922 !/ | GPL License | 923 !/ | Last update : 19-Dec-2007 | 924 !/ +-----------------------------------+ 925 !/ 926 ! 1. Purpose : 927 ! Advection of a scalar in a arbitary velocity field on unstructured meshes 928 ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space 929 ! This is the standard explicit N-Scheme from Roe as formulated in Abgrall 930 ! 931 ! 2. Method : 932 ! 933 ! 3. Parameters : 934 ! 935 ! Parameter list 936 ! ---------------------------------------------------------------- 937 ! ---------------------------------------------------------------- 938 ! 939 ! 4. Subroutines used : 940 ! 941 ! STRACE Subroutine tracing (!/S switch) 942 ! 943 ! 5. Called by : 944 ! 945 ! W3XYPUG Routine for advection on unstructured grid 946 ! 947 ! 6. Error messages : 948 ! 949 ! None. 950 ! 951 ! 7. Remarks : 952 ! 953 ! 8. Structure : 954 ! 955 ! See source code. 956 ! 957 ! 9. Switches : 958 ! 959 ! !/S Enable subroutine tracing. 960 ! 961 ! 10. Source code : 962 ! 963 !/ ------------------------------------------------------------------- / 964 !/ 965 USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & 966 IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, IAA, JAA, POSI, & 967 TRIA, NNZ 968 USE W3WDATMD, ONLY: TIME Page 28 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 969 USE W3ADATMD, ONLY: CG, ITER 970 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN 971 USE W3TIMEMD, ONLY: DSEC21 972 IMPLICIT NONE 973 974 INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction 975 REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the g 975 iven vel 976 REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, 977 REAL, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection 978 REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary conditions 979 LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step 980 REAL, INTENT(INOUT) :: AQ(:) 981 !/ 982 !/ ------------------------------------------------------------------- / 983 !/ Parameter list 984 !/ 985 !/ 986 !/ ------------------------------------------------------------------- / 987 !/ Local parameters 988 !/ 989 990 REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 991 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) 992 REAL, PARAMETER :: THR = TINY(1.0) 993 !/ 994 !/ ------------------------------------------------------------------- / 995 !/ 996 ! 997 ! local integer 998 ! 999 INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK 1000 INTEGER :: IBI, NI(3) 1001 ! 1002 ! local real 1003 ! 1004 REAL :: RD1, RD2 1005 !: 1006 ! local double 1007 ! 1008 REAL*8 :: IEN1(2), IEN2(2), IEN3(2) 1009 REAL*8 :: U1, U2, U3 1010 REAL*8 :: UTILDE 1011 REAL*8 :: SUMTHETA 1012 REAL*8 :: FL1, FL2, FL3 1013 REAL*8 :: FT, CFLXY 1014 REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 1015 REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 1016 REAL*8 :: DTSI(NX), U(NX) 1017 REAL*8 :: DTMAXGL, DTMAXEXP, REST 1018 REAL*8 :: LAMBDA(2), KTMP(3) 1019 REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI), KP(3,NTRI) 1020 REAL*8 :: KKSUM(NX), ST(NX), K1, DTK, TMP3, KM(3), K(3) 1021 REAL*8 :: NM(NTRI), CRFS(3), DELTAL(3,NTRI) 1022 REAL*8 :: B(NX), X(NX) 1023 REAL*8 :: ASPAR(NNZ) 1024 Page 29 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 1025 INTEGER :: IWKSP( 20*NX ) 1026 INTEGER :: FLJU(NX) 1027 INTEGER :: FLJAU(NNZ+1) 1028 1029 1030 INTEGER :: POS_TRICK(3,2) 1031 1032 INTEGER :: IPAR(16) 1033 INTEGER :: IERROR ! IWK ! ERROR Indicator and Work Array Size, 1034 INTEGER :: JAU(NNZ+1), JU(NX) 1035 1036 REAL*8 :: FPAR(16) ! DROPTOL 1037 REAL*8 :: WKSP( 8 * NX ) ! REAL WORKSPACES 1038 REAL*8 :: AU(NNZ+1) 1039 REAL*8 :: INIU(NX) 1040 1041 external bcgstab 1042 external gmres 1043 1044 POS_TRICK(1,1) = 2 1045 POS_TRICK(1,2) = 3 1046 POS_TRICK(2,1) = 3 1047 POS_TRICK(2,2) = 1 1048 POS_TRICK(3,1) = 1 1049 POS_TRICK(3,2) = 2 1050 1051 1052 ! 1. initialisation 1053 1054 ITH = 1 + MOD(ISP-1,NTH) 1055 IK = 1 + (ISP-1)/NTH 1056 DTMAXGL = DBLE(10.E10) 1057 1058 ! IF (SUM(AC) .GT. 0. .OR. SUM(AQ) .GT. 0) THEN 1059 IF (.FALSE.) THEN 1060 WRITE(*,*) 'NNZ', NNZ 1061 WRITE(*,*) 'MINVAL IAA,JAA', MINVAL(IAA), MINVAL(JAA) 1062 WRITE(*,*) 'MINVAL IAA,JAA', MAXVAL(IAA), MAXVAL(JAA) 1063 WRITE(*,*) 'MAX/MIN POSI', MAXVAL(POSI), MINVAL(POSI) 1064 WRITE(*,*) 'AC, AQ', SUM(AC), SUM(AQ) 1065 END IF 1066 ! 1067 !2 Propagation 1068 !2.a Calculate K-Values and contour based quantities ... 1069 ! 1070 DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... 1071 I1 = TRIGP(IE,1) ! Index of the Element Nodes (TRIGP) 1072 I2 = TRIGP(IE,2) 1073 I3 = TRIGP(IE,3) 1074 LAMBDA(1) = ONESIXTH * (C(I1,1)+C(I2,1)+C(I3,1)) 1075 LAMBDA(2) = ONESIXTH * (C(I1,2)+C(I2,2)+C(I3,2)) 1076 K(1) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) 1077 K(2) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) 1078 K(3) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) 1079 KP(1,IE) = MAX(0.d0,K(1)) 1080 KP(2,IE) = MAX(0.d0,K(2)) 1081 KP(3,IE) = MAX(0.d0,K(3)) Page 30 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 1082 KM(1) = MIN(0.d0,K(1)) 1083 KM(2) = MIN(0.d0,K(2)) 1084 KM(3) = MIN(0.d0,K(3)) 1085 FL11 = C(I2,1)*IEN(IE,1)+C(I2,2)*IEN(IE,2) 1086 FL12 = C(I3,1)*IEN(IE,1)+C(I3,2)*IEN(IE,2) 1087 FL21 = C(I3,1)*IEN(IE,3)+C(I3,2)*IEN(IE,4) 1088 FL22 = C(I1,1)*IEN(IE,3)+C(I1,2)*IEN(IE,4) 1089 FL31 = C(I1,1)*IEN(IE,5)+C(I1,2)*IEN(IE,6) 1090 FL32 = C(I2,1)*IEN(IE,5)+C(I2,2)*IEN(IE,6) 1091 CRFS(1) = - ONESIXTH * (2.0d0 *FL31 + FL32 + FL21 + 2.0d0 * FL22 ) 1092 CRFS(2) = - ONESIXTH * (2.0d0 *FL32 + 2.0d0 * FL11 + FL12 + FL31 ) 1093 CRFS(3) = - ONESIXTH * (2.0d0 *FL12 + 2.0d0 * FL21 + FL22 + FL11 ) 1094 DELTAL(:,IE) = CRFS(:)- KP(:,IE) 1095 NM(IE) = 1.d0/MIN(DBLE(THR),SUM(KM(:))) 1096 END DO ! NTRI 1097 1098 U = DBLE(AC) 1099 J = 0 1100 ASPAR = 0.d0 1101 B = 0.d0 1102 DO IP = 1, NX 1103 DO I = 1, CCON(IP) 1104 J = J + 1 1105 IE = IE_CELL(J) 1106 POS = POS_CELL(J) 1107 K1 = KP(POS,IE) * IOBPD(ITH,IP) 1108 IF (K1 > 0.) THEN 1109 DTK = K1 * DT 1110 TMP3 = DTK * NM(IE) 1111 I1 = POSI(1,J) 1112 I2 = POSI(2,J) 1113 I3 = POSI(3,J) 1114 ASPAR(I1) = 1./3. * TRIA(IE) + DTK - TMP3 * DELTAL(POS,IE) + ASPAR(I1) 1115 ASPAR(I2) = - TMP3 * DELTAL(POS_TRICK(POS,1),IE) + ASPAR(I2) 1116 ASPAR(I3) = - TMP3 * DELTAL(POS_TRICK(POS,2),IE) + ASPAR(I3) 1117 B(IP) = B(IP) + 1./3. * TRIA(IE) * U(IP) 1118 ELSE 1119 I1 = POSI(1,J) 1120 ASPAR(I1) = 1./3. * TRIA(IE) + ASPAR(I1) 1121 B(IP) = B(IP) + 1./3. * TRIA(IE) * U(IP) 1122 END IF 1123 END DO ! End loop over connected elements ... 1124 END DO 1125 ! 1126 !2DO setup a semi-implicit integration scheme for source terms only ... 1127 ! 1128 IPAR(1) = 0 ! always 0 to start an iterative solver 1129 IPAR(2) = 1 ! right preconditioning 1130 IPAR(3) = 1 ! use convergence test scheme 1 1131 IPAR(4) = 8*NX ! 1132 IPAR(5) = 15 1133 IPAR(6) = 1000 ! use at most 1000 matvec's 1134 FPAR(1) = DBLE(1.0E-8) ! relative tolerance 1.0E-6 1135 FPAR(2) = DBLE(1.0E-10) ! absolute tolerance 1.0E-10 1136 FPAR(11) = 0.d0 ! clearing the FLOPS counter 1137 1138 AU = 0. Page 31 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 1139 FLJAU = 0 1140 FLJU = 0 1141 JAU = 0 1142 JU = 0 1143 1144 CALL ILU0 (NX, ASPAR, JAA, IAA, AU, FLJAU, FLJU, IWKSP, IERROR) 1145 1146 ! WRITE(*,*) 'PRECONDITIONER', IERROR 1147 1148 ! IF (SUM(AC) .GT. 0. .OR. SUM(AQ) .GT. 0) THEN 1149 IF (.FALSE.) THEN 1150 WRITE(*,*) SUM(AC), SUM(AQ) 1151 WRITE(*,*) 'CALL SOLVER' 1152 WRITE(*,*) 'WRITE CG', SUM(CG) 1153 WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) 1154 WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) 1155 WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) 1156 WRITE(*,*) 'ASPAR, JAA, IAA',SUM(ASPAR), SUM(IAA), SUM(JAA) 1157 WRITE(*,*) 'AU, FLJAU, FLJU',SUM(AU), SUM(FLJAU), SUM(FLJU) 1158 END IF 1159 1160 INIU = U 1161 X = 0.d0 1162 1163 CALL RUNRC (NX, B, X, IPAR, FPAR, WKSP, INIU, ASPAR, JAA, IAA, AU, FLJAU, FLJU, BCGSTAB) 1164 1165 ! IF (SUM(AC) .GT. 0. .OR. SUM(AQ) .GT. 0) THEN 1166 IF (.FALSE.) THEN 1167 WRITE(*,*) 'SOLUTION' 1168 WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) 1169 WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) 1170 WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) 1171 WRITE(*,*) 'ASPAR, JAA, IAA', SUM(ASPAR), SUM(JAA), SUM(IAA) 1172 WRITE(*,*) 'AU, FLJAU, FLJU', SUM(AU), SUM(FLJAU), SUM(FLJU) 1173 END IF 1174 1175 DO IP = 1,NX 1176 U(IP) = MAX(0.d0,X(IP)) * DBLE(IOBPD(ITH,IP)) 1177 END DO 1178 1179 ! IF (SUM(AC) .GT. 0. .OR. SUM(AQ) .GT. 0) THEN 1180 IF (.FALSE.) THEN 1181 WRITE(*,*) 'SOLUTION' 1182 WRITE(*,*) 'B, X, AC, U', SUM(B), SUM(X), SUM(AC), SUM(U) 1183 WRITE(*,*) 'IPAR, FPAR', SUM(IPAR), SUM(FPAR) 1184 WRITE(*,*) 'WKSP, INIU', SUM(WKSP), SUM(INIU) 1185 WRITE(*,*) 'ASPAR, JAA, IAA', SUM(ASPAR), SUM(JAA), SUM(IAA) 1186 WRITE(*,*) 'AU, FLJAU, FLJU', SUM(AU), SUM(FLJAU), SUM(FLJU) 1187 END IF 1188 1189 AC = REAL(U) 1190 ! 1191 ! 5 Update boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ... 1192 ! 1193 IF ( FLBPI ) THEN 1194 RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) 1195 RD2=RD20 Page 32 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 1196 IF ( RD2 .GT. 0.001 ) THEN 1197 RD2 = MIN(1.,MAX(0.,RD1/RD2)) 1198 RD1 = 1. - RD2 1199 ELSE 1200 RD1 = 0. 1201 RD2 = 1. 1202 END IF 1203 ! 1204 ! NB: this treatment of the open boundary (time interpolation) is different from 1205 ! the constant boundary in the structured grids ... which restores the boundary 1206 ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) 1207 ! Why this difference ? 1208 ! 1209 DO IBI=1, NBI 1210 IP = MAPSF(ISBPI(IBI),1) 1211 AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & 1212 / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) 1213 END DO 1214 END IF 1215 ! WRITE(6,*) 'ITER:',IK, ITH, LCALC, ITER(IK,ITH),IT,RD10,RD20,RD1,RD2 1216 1217 ! CALL EXTCDE ( 99 ) 1218 !/ 1219 !/ End of W3XYPFSN ----------------------------------------------------- / 1220 !/ 1221 END SUBROUTINE W3XYPFSNIMP ENTRY POINTS Name w3profsmd_mp_w3xypfsnimp_ Page 33 Source Listing W3XYPFSNIMP 2014-09-16 16:49 Symbol Table w3profsmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References AC Dummy 914 R(4) 4 1 1 ARG,INOUT 1064,1098,1150,1153,1168,1182,1189 ,1211 AQ Dummy 914 R(4) 4 1 1 ARG,INOUT 1064,1150 ASPAR Local 1023 R(8) 8 1 0 1100,1114,1115,1116,1120,1144,1156 ,1163,1171,1185 AU Local 1038 R(8) 8 1 0 1138,1144,1157,1163,1172,1186 B Local 1022 R(8) 8 1 0 1101,1117,1121,1153,1163,1168,1182 BBPI0 Local 970 R(4) 4 2 1 PTR 970,1211 BBPIN Local 970 R(4) 4 2 1 PTR 970,1211 BCGSTAB Subr 1041 scalar 1163 C Dummy 914 R(4) 4 2 1 ARG,IN 1074,1075,1085,1086,1087,1088,1089 ,1090 CCON Local 965 I(4) 4 1 1 PTR 965,1103 CFLXY Local 1013 R(8) 8 scalar CG Local 969 R(4) 4 2 1 PTR 969,1152,1212 CLATS Local 966 R(4) 4 1 1 PTR 966,1212 CRFS Local 1021 R(8) 8 1 3 1091,1092,1093,1094 DBLE Func 1056 scalar 1056,1095,1098,1134,1135,1176 DELTAL Local 1021 R(8) 8 2 0 1094,1114,1115,1116 DSEC21 Func 971 R(4) 4 scalar 971 DT Dummy 914 R(4) 4 scalar ARG,IN 1109,1194 DTK Local 1020 R(8) 8 scalar 1109,1110,1114 DTMAXEXP Local 1017 R(8) 8 scalar DTMAXGL Local 1017 R(8) 8 scalar 1056 DTSI Local 1016 R(8) 8 1 0 FL1 Local 1012 R(8) 8 scalar FL11 Local 1014 R(8) 8 scalar 1085,1092,1093 FL111 Local 1015 R(8) 8 scalar FL112 Local 1015 R(8) 8 scalar FL12 Local 1014 R(8) 8 scalar 1086,1092,1093 FL2 Local 1012 R(8) 8 scalar FL21 Local 1014 R(8) 8 scalar 1087,1091,1093 FL211 Local 1015 R(8) 8 scalar FL212 Local 1015 R(8) 8 scalar FL22 Local 1014 R(8) 8 scalar 1088,1091,1093 FL3 Local 1012 R(8) 8 scalar FL31 Local 1014 R(8) 8 scalar 1089,1091,1092 FL311 Local 1015 R(8) 8 scalar FL312 Local 1015 R(8) 8 scalar FL32 Local 1014 R(8) 8 scalar 1090,1091,1092 FLALL Local 1019 R(8) 8 2 0 FLBPI Local 970 L(4) 4 scalar PTR 970,1193 FLJAU Local 1027 I(4) 4 1 0 1139,1144,1157,1163,1172,1186 FLJU Local 1026 I(4) 4 1 0 1140,1144,1157,1163,1172,1186 FPAR Local 1036 R(8) 8 1 16 1134,1135,1136,1154,1163,1169,1183 FT Local 1013 R(8) 8 scalar GMRES Subr 1042 scalar I Local 999 I(4) 4 scalar 1103 I1 Local 999 I(4) 4 scalar 1071,1074,1075,1088,1089,1111,1114 ,1119,1120 I2 Local 999 I(4) 4 scalar 1072,1074,1075,1085,1090,1112,1115 Page 34 Source Listing W3XYPFSNIMP 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References I3 Local 999 I(4) 4 scalar 1073,1074,1075,1086,1087,1113,1116 IAA Local 966 I(4) 4 1 1 PTR 966,1061,1062,1144,1156,1163,1171, 1185 IBI Local 1000 I(4) 4 scalar 1209,1210,1211,1212 IE Local 999 I(4) 4 scalar 1070,1071,1072,1073,1076,1077,1078 ,1079,1080,1081,1085,1086,1087,108 8,1089,1090,1094,1095,1105,1107,11 10,1114,1115,1116,1117,1120,1121 IEN Local 966 R(4) 4 2 1 PTR 966,1076,1077,1078,1085,1086,1087, 1088,1089,1090 IEN1 Local 1008 R(8) 8 1 2 IEN2 Local 1008 R(8) 8 1 2 IEN3 Local 1008 R(8) 8 1 2 IERROR Local 1033 I(4) 4 scalar 1144 IE_CELL Local 965 I(4) 4 1 1 PTR 965,1105 IK Local 999 I(4) 4 scalar 1055,1194,1212 ILU0 Subr 1144 1144 INIU Local 1039 R(8) 8 1 0 1155,1160,1163,1170,1184 IOBP Local 966 I(4) 4 1 1 PTR 966 IOBPD Local 966 I(4) 4 2 1 PTR 966,1107,1176 IP Local 999 I(4) 4 scalar 1102,1103,1107,1117,1121,1175,1176 ,1210,1211 IPAR Local 1032 I(4) 4 1 16 1128,1129,1130,1131,1132,1133,1154 ,1163,1169,1183 ISBPI Local 970 I(4) 4 1 1 PTR 970,1210,1212 ISP Dummy 914 I(4) 4 scalar ARG,IN 1054,1055,1211 IT Local 999 I(4) 4 scalar 1194 ITER Local 969 I(4) 4 2 1 PTR 969,1194 ITH Local 999 I(4) 4 scalar 1054,1107,1176,1194 IWKSP Local 1025 I(4) 4 1 0 1144 J Local 999 I(4) 4 scalar 1099,1104,1105,1106,1111,1112,1113 ,1119 JAA Local 966 I(4) 4 1 1 PTR 966,1061,1062,1144,1156,1163,1171, 1185 JAU Local 1034 I(4) 4 1 0 1141 JU Local 1034 I(4) 4 1 0 1142 K Local 1020 R(8) 8 1 3 1076,1077,1078,1079,1080,1081,1082 ,1083,1084 K1 Local 1020 R(8) 8 scalar 1107,1108,1109 KELEM Local 1019 R(8) 8 2 0 KKSUM Local 1020 R(8) 8 1 0 KM Local 1020 R(8) 8 1 3 1082,1083,1084,1095 KP Local 1019 R(8) 8 2 0 1079,1080,1081,1094,1107 KTMP Local 1018 R(8) 8 1 3 LAMBDA Local 1018 R(8) 8 1 2 1074,1075,1076,1077,1078 LCALC Dummy 914 L(4) 4 scalar ARG,IN MAPSF Local 966 I(4) 4 2 1 PTR 966,1210 MAX Func 1079 scalar 1079,1080,1081,1176,1197 MAXVAL Func 1062 scalar 1062,1063 MIN Func 1082 scalar 1082,1083,1084,1095,1197 MINVAL Func 1061 scalar 1061,1063 MOD Func 1054 scalar 1054 NBI Local 970 I(4) 4 scalar PTR 970,1209 NDSE Local 970 I(4) 4 scalar PTR 970 NDST Local 970 I(4) 4 scalar PTR 970 Page 35 Source Listing W3XYPFSNIMP 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References NI Local 1000 I(4) 4 1 3 NK Local 965 I(4) 4 scalar PTR 965 NM Local 1021 R(8) 8 1 0 1095,1110 NNZ Local 967 I(4) 4 scalar PTR 967,1023,1027,1034,1038,1060 NTH Local 965 I(4) 4 scalar PTR 965,1054,1055 NTRI Local 965 I(4) 4 scalar PTR 965,1019,1021,1070 NX Local 965 I(4) 4 scalar PTR 965,1016,1020,1022,1025,1026,1034, 1037,1039,1102,1131,1144,1163,1175 ONESIXTH Param 990 R(8) 8 scalar 1074,1075,1091,1092,1093 POS Local 999 I(4) 4 scalar 1106,1107,1114,1115,1116 POSI Local 966 I(4) 4 2 1 PTR 966,1063,1111,1112,1113,1119 POS_CELL Local 965 I(4) 4 1 1 PTR 965,1106 POS_TRICK Local 1030 I(4) 4 2 6 1044,1045,1046,1047,1048,1049,1115 ,1116 RD1 Local 1004 R(4) 4 scalar 1194,1197,1198,1200,1211 RD10 Dummy 914 R(4) 4 scalar ARG,IN 1194 RD2 Local 1004 R(4) 4 scalar 1195,1196,1197,1198,1201,1211 RD20 Dummy 914 R(4) 4 scalar ARG,IN 1195 REAL Func 1189 scalar 1189,1194 REST Local 1017 R(8) 8 scalar RUNRC Subr 1163 1163 SI Local 965 R(4) 4 1 1 PTR 965 ST Local 1020 R(8) 8 1 0 SUM Func 1064 scalar 1064,1095,1150,1152,1153,1154,1155 ,1156,1157,1168,1169,1170,1171,117 2,1182,1183,1184,1185,1186 SUMTHETA Local 1011 R(8) 8 scalar TBPI0 Local 970 I(4) 4 1 1 PTR 970 TBPIN Local 970 I(4) 4 1 1 PTR 970 THR Param 992 R(4) 4 scalar 1095 THR8 Param 991 R(8) 8 scalar TIME Local 968 I(4) 4 1 1 PTR 968 TINY Func 991 scalar 991,992 TMP3 Local 1020 R(8) 8 scalar 1110,1114,1115,1116 TRIA Local 967 R(4) 4 1 1 PTR 967,1114,1117,1120,1121 TRIGP Local 966 I(4) 4 2 1 PTR 966,1071,1072,1073 U Local 1016 R(8) 8 1 0 1098,1117,1121,1153,1160,1168,1176 ,1182,1189 U1 Local 1009 R(8) 8 scalar U2 Local 1009 R(8) 8 scalar U3 Local 1009 R(8) 8 scalar UTILDE Local 1010 R(8) 8 scalar W3ADATMD Module 969 969 W3GDATMD Module 965 965 W3ODATMD Module 970 970 W3TIMEMD Module 971 971 W3WDATMD Module 968 968 W3XYPFSNIMP Subr 914 235 WKSP Local 1037 R(8) 8 1 0 1155,1163,1170,1184 X Local 1022 R(8) 8 1 0 1153,1161,1163,1168,1176,1182 Page 36 Source Listing W3XYPFSNIMP 2014-09-16 16:49 w3profsmd.f90 1222 1223 !/ ------------------------------------------------------------------- / 1224 1225 SUBROUTINE W3XYPFSFCT2 ( ISP, C, LCALC, RD10, RD20, DT, AC, AQ) 1226 1227 !/ 1228 !/ 1229 !/ +-----------------------------------+ 1230 !/ | WWIII Version of the WWM FS Code | 1231 !/ | by Aron Roland | 1232 !/ | for use in WWIII | 1233 !/ | GPL License | 1234 !/ | Last update : 19-Dec-2007 | 1235 !/ +-----------------------------------+ 1236 !/ 1237 ! 1. Purpose : 1238 ! Advection of a scalar in a arbitary velocity field on unstructured meshes 1239 ! for the conservative hyperbolic equation N,t + (c*N),xy = 0 in spatial space 1240 ! 1241 ! 2. Method : 1242 ! 1243 ! 3. Parameters : 1244 ! 1245 ! Parameter list 1246 ! ---------------------------------------------------------------- 1247 ! ---------------------------------------------------------------- 1248 ! 1249 ! 4. Subroutines used : 1250 ! 1251 ! STRACE Subroutine tracing (!/S switch) 1252 ! 1253 ! 5. Called by : 1254 ! 1255 ! W3XYPUG Routine for advection on unstructured grid 1256 ! 1257 ! 6. Error messages : 1258 ! 1259 ! None. 1260 ! 1261 ! 7. Remarks : 1262 ! 1263 ! 8. Structure : 1264 ! 1265 ! See source code. 1266 ! 1267 ! 9. Switches : 1268 ! 1269 ! !/S Enable subroutine tracing. 1270 ! 1271 ! 10. Source code : 1272 ! 1273 !/ ------------------------------------------------------------------- / 1274 !/ 1275 USE W3GDATMD, ONLY : NK, NTH, NTRI, NX, CCON, IE_CELL,POS_CELL, SI, & 1276 IEN, TRIGP, CLATS, MAPSF, IOBPD, IOBP, TRIA 1277 USE W3WDATMD, ONLY: TIME 1278 USE W3ADATMD, ONLY: CG, ITER Page 37 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1279 USE W3ODATMD, ONLY: NDSE, NDST, FLBPI, NBI, TBPI0, TBPIN, ISBPI, BBPI0, BBPIN 1280 USE W3TIMEMD, ONLY: DSEC21 1281 IMPLICIT NONE 1282 1283 INTEGER, INTENT(IN) :: ISP ! Actual Frequency/Wavenumber, actual Wave Direction 1284 REAL, INTENT(IN) :: DT ! Time intervall for which the advection should be computed for the g 1284 iven vel 1285 REAL, INTENT(IN) :: C(:,:) ! Velocity field in it's X- and Y- Components, 1286 REAL, INTENT(INOUT) :: AC(:) ! Wave Action before and after advection 1287 REAL, INTENT(IN) :: RD10, RD20 ! Time interpolation coefficients for boundary condition 1288 LOGICAL, INTENT(IN) :: LCALC ! Switch for the calculation of the max. Global Time step 1289 REAL, INTENT(INOUT) :: AQ(:) 1290 !/ 1291 !/ ------------------------------------------------------------------- / 1292 !/ Parameter list 1293 !/ 1294 !/ 1295 !/ ------------------------------------------------------------------- / 1296 !/ Local parameters 1297 !/ 1298 1299 REAL*8, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 1300 REAL*8, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 1301 REAL*8, PARAMETER :: THR8 = TINY(1.0d0) 1302 REAL, PARAMETER :: THR = TINY(1.0) 1303 !/ 1304 !/ ------------------------------------------------------------------- / 1305 !/ 1306 ! 1307 ! local integer 1308 ! 1309 INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK 1310 INTEGER :: IBI, NI(3) 1311 ! 1312 ! local real 1313 ! 1314 REAL :: RD1, RD2 1315 !: 1316 ! local double 1317 ! 1318 REAL*8 :: IEN1(2), IEN2(2), IEN3(2) 1319 REAL*8 :: U1, U2, U3 1320 REAL*8 :: UTILDE 1321 REAL*8 :: SUMTHETA 1322 REAL*8 :: FL1, FL2, FL3 1323 REAL*8 :: FT, CFLXY 1324 REAL*8 :: FL11, FL12, FL21, FL22, FL31, FL32 1325 REAL*8 :: FL111, FL112, FL211, FL212, FL311, FL312 1326 REAL*8 :: DTSI(NX), U(NX), DT4AI, TMP1 1327 REAL*8 :: DTMAXGL, DTMAXEXP, REST 1328 REAL*8 :: LAMBDA(2), KTMP(3), TMP(3) 1329 REAL*8 :: BET1(3), BETAHAT(3) 1330 REAL*8 :: THETA_L(3,NTRI), THETA_H(3,NTRI), THETA_ACE(3,NTRI), UTMP(3) 1331 REAL*8 :: WII(2,NX), UL(NX), USTARI(2,NX) 1332 1333 REAL*8 :: PM(NX), PP(NX), UIM(NX), UIP(NX) 1334 Page 38 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1335 REAL*8 :: KELEM(3,NTRI), FLALL(3,NTRI) 1336 REAL*8 :: KKSUM(NX), ST(NX), BETA 1337 REAL*8 :: NM(NTRI) 1338 1339 1340 ! 1. initialisation 1341 1342 ITH = 1 + MOD(ISP-1,NTH) 1343 IK = 1 + (ISP-1)/NTH 1344 DTMAXGL = DBLE(10.E10) 1345 ! 1346 !2 Propagation 1347 !2.a Calculate K-Values and contour based quantities ... 1348 ! 1349 DO IE = 1, NTRI ! I precacalculate this arrays below as I assume that current velocity changes continusly ... 1350 I1 = TRIGP(IE,1) ! Index of the Element Nodes (TRIGP) 1351 I2 = TRIGP(IE,2) 1352 I3 = TRIGP(IE,3) 1353 LAMBDA(1) = ONESIXTH *(C(I1,1)+C(I2,1)+C(I3,1)) ! Linearized advection speed in X and Y direction 1354 LAMBDA(2) = ONESIXTH *(C(I1,2)+C(I2,2)+C(I3,2)) 1355 KELEM(1,IE) = LAMBDA(1) * IEN(IE,1) + LAMBDA(2) * IEN(IE,2) ! K-Values - so called Flux Jacobians 1356 KELEM(2,IE) = LAMBDA(1) * IEN(IE,3) + LAMBDA(2) * IEN(IE,4) 1357 KELEM(3,IE) = LAMBDA(1) * IEN(IE,5) + LAMBDA(2) * IEN(IE,6) 1358 KTMP = KELEM(:,IE) ! Copy 1359 NM(IE) = - 1.D0/MIN(-THR8,SUM(MIN(0.d0,KTMP))) ! N-Values 1360 FL11 = C(I2,1) * IEN(IE,1) + C(I2,2) * IEN(IE,2) ! Weights for Simpson Integration 1361 FL12 = C(I3,1) * IEN(IE,1) + C(I3,2) * IEN(IE,2) 1362 FL21 = C(I3,1) * IEN(IE,3) + C(I3,2) * IEN(IE,4) 1363 FL22 = C(I1,1) * IEN(IE,3) + C(I1,2) * IEN(IE,4) 1364 FL31 = C(I1,1) * IEN(IE,5) + C(I1,2) * IEN(IE,6) 1365 FL32 = C(I2,1) * IEN(IE,5) + C(I2,2) * IEN(IE,6) 1366 FL111 = 2.d0*FL11+FL12 1367 FL112 = 2.d0*FL12+FL11 1368 FL211 = 2.d0*FL21+FL22 1369 FL212 = 2.d0*FL22+FL21 1370 FL311 = 2.d0*FL31+FL32 1371 FL312 = 2.d0*FL32+FL31 1372 FLALL(1,IE) = (FL311 + FL212)! * ONESIXTH + KELEM(1,IE) 1373 FLALL(2,IE) = (FL111 + FL312)! * ONESIXTH + KELEM(2,IE) 1374 FLALL(3,IE) = (FL211 + FL112)! * ONESIXTH + KELEM(3,IE) 1375 END DO ! NTRI 1376 1377 IF (LCALC) THEN ! If the current field or water level changes estimate the iteration number based on the new flow 1377 field a 1378 KKSUM = 0.d0 1379 DO IE = 1, NTRI 1380 NI = TRIGP(IE,:) 1381 KKSUM(NI) = KKSUM(NI) + KELEM(:,IE) 1382 END DO ! IE 1383 DO IP = 1, NX 1384 ! DTMAXEXP = MAX( ABS(DBLE(IOBP(IP))*DBLE(10.E10)),SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)*DBLE(OBPD(ITH,IP)))) 1385 DTMAXEXP = SI(IP)/MAX(DBLE(10.E-10),KKSUM(IP)) 1386 DTMAXGL = MIN( DTMAXGL, DTMAXEXP) 1387 END DO ! IP 1388 CFLXY = DBLE(DT)/DTMAXGL 1389 REST = ABS(MOD(CFLXY,1.0d0)) 1390 IF (REST .LT. THR8) THEN Page 39 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1391 ITER(IK,ITH) = ABS(NINT(CFLXY)) 1392 ELSE IF (REST .GT. THR8 .AND. REST .LT. 0.5d0) THEN 1393 ITER(IK,ITH) = ABS(NINT(CFLXY)) + 1 1394 ELSE 1395 ITER(IK,ITH) = ABS(NINT(CFLXY)) 1396 END IF 1397 END IF ! LCALC 1398 1399 DT4AI = DBLE(DT)/DBLE(ITER(IK,ITH)) 1400 DTSI(:) = DT4AI/SI(:) ! Some precalculations for the time integration. 1401 1402 U = DBLE(AC) 1403 UL = U 1404 1405 DO IT = 1, ITER(IK,ITH) 1406 1407 ST = 0.d0 1408 DO IE = 1, NTRI 1409 NI = TRIGP(IE,:) 1410 UTMP = U(NI) 1411 FT = - ONESIXTH*DOT_PRODUCT(UTMP,FLALL(:,IE)) 1412 TMP = MAX(0.d0,KELEM(:,IE)) 1413 UTILDE = NM(IE) * ( DOT_PRODUCT(TMP,UTMP) - FT ) 1414 THETA_L(:,IE) = TMP * ( UTMP - UTILDE ) 1415 IF (ABS(FT) .GT. DBLE(THR)) THEN 1416 BET1(:) = THETA_L(:,IE)/FT 1417 IF (ANY( BET1 .LT. 0.0d0) ) THEN 1418 BETAHAT(1) = BET1(1) + 0.5d0 * BET1(2) 1419 BETAHAT(2) = BET1(2) + 0.5d0 * BET1(3) 1420 BETAHAT(3) = BET1(3) + 0.5d0 * BET1(1) 1421 BET1(1) = MAX(0.d0,MIN(BETAHAT(1),1.d0-BETAHAT(2),1.d0)) 1422 BET1(2) = MAX(0.d0,MIN(BETAHAT(2),1.d0-BETAHAT(3),1.d0)) 1423 BET1(3) = MAX(0.d0,MIN(BETAHAT(3),1.d0-BETAHAT(1),1.d0)) 1424 THETA_L(:,IE) = FT * BET1 1425 END IF 1426 ELSE 1427 THETA_L(:,IE) = 0.d0 1428 END IF 1429 ! THETA_H(:,IE) = (ONETHIRD+DT4AI/(2.d0*TRIA(IE)) * KELEM(:,IE))*FT ! LAX-WENDROFF 1430 THETA_H(:,IE) = (1./3.+2./3.* KELEM(:,IE)/SUM(ABS(KELEM(:,IE))) )*FT ! CENTRAL SCHEME 1431 ! Antidiffusive residual according to the higher order nonmonotone scheme 1432 THETA_ACE(:,IE) = ((THETA_H(:,IE) - THETA_L(:,IE))) * DT4AI/SI(NI) 1433 ST(NI) = ST(NI) + THETA_L(:,IE)*DT4AI/SI(NI) 1434 END DO 1435 1436 ! UL = MAX(0.d0,U-ST)*DBLE(IOBPD(ITH,:))!*DBLE(IOBDP(:)) ... add for IOBDP dry/wet flag. 1437 1438 DO IP = 1,NX 1439 UL(IP) = MAX(0.d0,U(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) 1440 END DO 1441 1442 USTARI(1,:) = MAX(UL,U) 1443 USTARI(2,:) = MIN(UL,U) 1444 1445 UIP = -THR8 1446 UIM = THR8 1447 PP = 0.d0 Page 40 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1448 PM = 0.d0 1449 DO IE = 1, NTRI 1450 NI = TRIGP(IE,:) 1451 PP(NI) = PP(NI) + MAX( THR8, -THETA_ACE(:,IE)) 1452 PM(NI) = PM(NI) + MIN( -THR8, -THETA_ACE(:,IE)) 1453 UIP(NI) = MAX (UIP(NI), MAXVAL( USTARI(1,NI) )) 1454 UIM(NI) = MIN (UIM(NI), MINVAL( USTARI(2,NI) )) 1455 END DO 1456 1457 WII(1,:) = MIN(1.0d0,(UIP-UL)/MAX( THR8,PP)) 1458 WII(2,:) = MIN(1.0d0,(UIM-UL)/MIN(-THR8,PM)) 1459 1460 ST = 0.d0 1461 DO IE = 1, NTRI 1462 DO I = 1, 3 1463 IP = TRIGP(IE,I) 1464 IF (-THETA_ACE(I,IE) .GE. 0.) THEN 1465 TMP(I) = WII(1,IP) 1466 ELSE 1467 TMP(I) = WII(2,IP) 1468 END IF 1469 END DO 1470 BETA = MINVAL(TMP) 1471 NI = TRIGP(IE,:) 1472 ST(NI) = ST(NI) + BETA * THETA_ACE(:,IE) 1473 END DO 1474 1475 DO IP = 1,NX 1476 ! 1477 ! IOBPD is the switch for removing energy coming from the shoreline 1478 ! 1479 U(IP) = MAX(0.d0,UL(IP)-ST(IP))*DBLE(IOBPD(ITH,IP)) 1480 END DO 1481 AC = REAL(U) 1482 ! 1483 ! 5 Update open boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop .. 1483 . 1484 ! 1485 IF ( FLBPI ) THEN 1486 RD1=RD10 - DT * REAL(ITER(IK,ITH)-IT)/REAL(ITER(IK,ITH)) 1487 RD2=RD20 1488 IF ( RD2 .GT. 0.001 ) THEN 1489 RD2 = MIN(1.,MAX(0.,RD1/RD2)) 1490 RD1 = 1. - RD2 1491 ELSE 1492 RD1 = 0. 1493 RD2 = 1. 1494 END IF 1495 ! 1496 ! NB: this treatment of the open boundary (time interpolation) is different from 1497 ! the constant boundary in the structured grids ... which restores the boundary 1498 ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY) 1499 ! Why this difference ? 1500 ! 1501 DO IBI=1, NBI 1502 IP = MAPSF(ISBPI(IBI),1) 1503 AC(IP) = ( RD1*BBPI0(ISP,IBI) + RD2*BBPIN(ISP,IBI) ) & Page 41 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1504 / CG(IK,ISBPI(IBI)) * CLATS(ISBPI(IBI)) 1505 ENDDO 1506 END IF 1507 ! WRITE(6,*) 'ITER:',IK, ITH, LCALC, ITER(IK,ITH),IT,RD10,RD20,RD1,RD2 1508 1509 U = REAL(AC) 1510 1511 END DO ! IT 1512 ! CALL EXTCDE ( 99 ) 1513 !/ 1514 !/ End of W3XYPFSN ----------------------------------------------------- / 1515 !/ 1516 END SUBROUTINE W3XYPFSFCT2 ENTRY POINTS Name w3profsmd_mp_w3xypfsfct2_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 1389 scalar 1389,1391,1393,1395,1415,1430 AC Dummy 1225 R(4) 4 1 1 ARG,INOUT 1402,1481,1503,1509 ANY Func 1417 scalar 1417 AQ Dummy 1225 R(4) 4 1 1 ARG,INOUT BBPI0 Local 1279 R(4) 4 2 1 PTR 1279,1503 BBPIN Local 1279 R(4) 4 2 1 PTR 1279,1503 BET1 Local 1329 R(8) 8 1 3 1416,1417,1418,1419,1420,1421,1422 ,1423,1424 BETA Local 1336 R(8) 8 scalar 1470,1472 BETAHAT Local 1329 R(8) 8 1 3 1418,1419,1420,1421,1422,1423 C Dummy 1225 R(4) 4 2 1 ARG,IN 1353,1354,1360,1361,1362,1363,1364 ,1365 CCON Local 1275 I(4) 4 1 1 PTR 1275 CFLXY Local 1323 R(8) 8 scalar 1388,1389,1391,1393,1395 CG Local 1278 R(4) 4 2 1 PTR 1278,1504 CLATS Local 1276 R(4) 4 1 1 PTR 1276,1504 DBLE Func 1344 scalar 1344,1385,1388,1399,1402,1415,1439 ,1479 DOT_PRODUCT Func 1411 scalar 1411,1413 DSEC21 Func 1280 R(4) 4 scalar 1280 DT Dummy 1225 R(4) 4 scalar ARG,IN 1388,1399,1486 DT4AI Local 1326 R(8) 8 scalar 1399,1400,1432,1433 DTMAXEXP Local 1327 R(8) 8 scalar 1385,1386 DTMAXGL Local 1327 R(8) 8 scalar 1344,1386,1388 DTSI Local 1326 R(8) 8 1 0 1400 FL1 Local 1322 R(8) 8 scalar FL11 Local 1324 R(8) 8 scalar 1360,1366,1367 FL111 Local 1325 R(8) 8 scalar 1366,1373 FL112 Local 1325 R(8) 8 scalar 1367,1374 FL12 Local 1324 R(8) 8 scalar 1361,1366,1367 FL2 Local 1322 R(8) 8 scalar Page 42 Source Listing W3XYPFSFCT2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References FL21 Local 1324 R(8) 8 scalar 1362,1368,1369 FL211 Local 1325 R(8) 8 scalar 1368,1374 FL212 Local 1325 R(8) 8 scalar 1369,1372 FL22 Local 1324 R(8) 8 scalar 1363,1368,1369 FL3 Local 1322 R(8) 8 scalar FL31 Local 1324 R(8) 8 scalar 1364,1370,1371 FL311 Local 1325 R(8) 8 scalar 1370,1372 FL312 Local 1325 R(8) 8 scalar 1371,1373 FL32 Local 1324 R(8) 8 scalar 1365,1370,1371 FLALL Local 1335 R(8) 8 2 0 1372,1373,1374,1411 FLBPI Local 1279 L(4) 4 scalar PTR 1279,1485 FT Local 1323 R(8) 8 scalar 1411,1413,1415,1416,1424,1430 I Local 1309 I(4) 4 scalar 1462,1463,1464,1465,1467 I1 Local 1309 I(4) 4 scalar 1350,1353,1354,1363,1364 I2 Local 1309 I(4) 4 scalar 1351,1353,1354,1360,1365 I3 Local 1309 I(4) 4 scalar 1352,1353,1354,1361,1362 IBI Local 1310 I(4) 4 scalar 1501,1502,1503,1504 IE Local 1309 I(4) 4 scalar 1349,1350,1351,1352,1355,1356,1357 ,1358,1359,1360,1361,1362,1363,136 4,1365,1372,1373,1374,1379,1380,13 81,1408,1409,1411,1412,1413,1414,1 416,1424,1427,1430,1432,1433,1449, 1450,1451,1452,1461,1463,1464,1471 ,1472 IEN Local 1276 R(4) 4 2 1 PTR 1276,1355,1356,1357,1360,1361,1362 ,1363,1364,1365 IEN1 Local 1318 R(8) 8 1 2 IEN2 Local 1318 R(8) 8 1 2 IEN3 Local 1318 R(8) 8 1 2 IE_CELL Local 1275 I(4) 4 1 1 PTR 1275 IK Local 1309 I(4) 4 scalar 1343,1391,1393,1395,1399,1405,1486 ,1504 IOBP Local 1276 I(4) 4 1 1 PTR 1276 IOBPD Local 1276 I(4) 4 2 1 PTR 1276,1439,1479 IP Local 1309 I(4) 4 scalar 1383,1385,1438,1439,1463,1465,1467 ,1475,1479,1502,1503 ISBPI Local 1279 I(4) 4 1 1 PTR 1279,1502,1504 ISP Dummy 1225 I(4) 4 scalar ARG,IN 1342,1343,1503 IT Local 1309 I(4) 4 scalar 1405,1486 ITER Local 1278 I(4) 4 2 1 PTR 1278,1391,1393,1395,1399,1405,1486 ITH Local 1309 I(4) 4 scalar 1342,1391,1393,1395,1399,1405,1439 ,1479,1486 J Local 1309 I(4) 4 scalar KELEM Local 1335 R(8) 8 2 0 1355,1356,1357,1358,1381,1412,1430 KKSUM Local 1336 R(8) 8 1 0 1378,1381,1385 KTMP Local 1328 R(8) 8 1 3 1358,1359 LAMBDA Local 1328 R(8) 8 1 2 1353,1354,1355,1356,1357 LCALC Dummy 1225 L(4) 4 scalar ARG,IN 1377 MAPSF Local 1276 I(4) 4 2 1 PTR 1276,1502 MAX Func 1385 scalar 1385,1412,1421,1422,1423,1439,1442 ,1451,1453,1457,1479,1489 MAXVAL Func 1453 scalar 1453 MIN Func 1359 scalar 1359,1386,1421,1422,1423,1443,1452 ,1454,1457,1458,1489 MINVAL Func 1454 scalar 1454,1470 Page 43 Source Listing W3XYPFSFCT2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References MOD Func 1342 scalar 1342,1389 NBI Local 1279 I(4) 4 scalar PTR 1279,1501 NDSE Local 1279 I(4) 4 scalar PTR 1279 NDST Local 1279 I(4) 4 scalar PTR 1279 NI Local 1310 I(4) 4 1 3 1380,1381,1409,1410,1432,1433,1450 ,1451,1452,1453,1454,1471,1472 NINT Func 1391 scalar 1391,1393,1395 NK Local 1275 I(4) 4 scalar PTR 1275 NM Local 1337 R(8) 8 1 0 1359,1413 NTH Local 1275 I(4) 4 scalar PTR 1275,1342,1343 NTRI Local 1275 I(4) 4 scalar PTR 1275,1330,1335,1337,1349,1379,1408 ,1449,1461 NX Local 1275 I(4) 4 scalar PTR 1275,1326,1331,1333,1336,1383,1438 ,1475 ONESIXTH Param 1299 R(8) 8 scalar 1353,1354,1411 ONETHIRD Param 1300 R(8) 8 scalar PM Local 1333 R(8) 8 1 0 1448,1452,1458 POS Local 1309 I(4) 4 scalar POS_CELL Local 1275 I(4) 4 1 1 PTR 1275 PP Local 1333 R(8) 8 1 0 1447,1451,1457 RD1 Local 1314 R(4) 4 scalar 1486,1489,1490,1492,1503 RD10 Dummy 1225 R(4) 4 scalar ARG,IN 1486 RD2 Local 1314 R(4) 4 scalar 1487,1488,1489,1490,1493,1503 RD20 Dummy 1225 R(4) 4 scalar ARG,IN 1487 REAL Func 1481 scalar 1481,1486,1509 REST Local 1327 R(8) 8 scalar 1389,1390,1392 SI Local 1275 R(4) 4 1 1 PTR 1275,1385,1400,1432,1433 ST Local 1336 R(8) 8 1 0 1407,1433,1439,1460,1472,1479 SUM Func 1359 scalar 1359,1430 SUMTHETA Local 1321 R(8) 8 scalar TBPI0 Local 1279 I(4) 4 1 1 PTR 1279 TBPIN Local 1279 I(4) 4 1 1 PTR 1279 THETA_ACE Local 1330 R(8) 8 2 0 1432,1451,1452,1464,1472 THETA_H Local 1330 R(8) 8 2 0 1430,1432 THETA_L Local 1330 R(8) 8 2 0 1414,1416,1424,1427,1432,1433 THR Param 1302 R(4) 4 scalar 1415 THR8 Param 1301 R(8) 8 scalar 1359,1390,1392,1445,1446,1451,1452 ,1457,1458 TIME Local 1277 I(4) 4 1 1 PTR 1277 TINY Func 1301 scalar 1301,1302 TMP Local 1328 R(8) 8 1 3 1412,1413,1414,1465,1467,1470 TMP1 Local 1326 R(8) 8 scalar TRIA Local 1276 R(4) 4 1 1 PTR 1276 TRIGP Local 1276 I(4) 4 2 1 PTR 1276,1350,1351,1352,1380,1409,1450 ,1463,1471 U Local 1326 R(8) 8 1 0 1402,1403,1410,1439,1442,1443,1479 ,1481,1509 U1 Local 1319 R(8) 8 scalar U2 Local 1319 R(8) 8 scalar U3 Local 1319 R(8) 8 scalar UIM Local 1333 R(8) 8 1 0 1446,1454,1458 UIP Local 1333 R(8) 8 1 0 1445,1453,1457 UL Local 1331 R(8) 8 1 0 1403,1439,1442,1443,1457,1458,1479 USTARI Local 1331 R(8) 8 2 0 1442,1443,1453,1454 UTILDE Local 1320 R(8) 8 scalar 1413,1414 Page 44 Source Listing W3XYPFSFCT2 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References UTMP Local 1330 R(8) 8 1 3 1410,1411,1413,1414 W3ADATMD Module 1278 1278 W3GDATMD Module 1275 1275 W3ODATMD Module 1279 1279 W3TIMEMD Module 1280 1280 W3WDATMD Module 1277 1277 W3XYPFSFCT2 Subr 1225 233 WII Local 1331 R(8) 8 2 0 1457,1458,1465,1467 Page 45 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1517 1518 !/ ------------------------------------------------------------------- / 1519 1520 END MODULE W3PROFSMD SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References W3PROFSMD Module 2 Page 46 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1521 1522 1523 !-------------------------------------------------------------------------- 1524 !-------------------------------------------------------------------------- 1525 !-------------------------------------------------------------------------- 1526 !------------------iterative solver --------------------------------------- 1527 !----------------------------------------------------------------------c 1528 ! S P A R S K I T c 1529 !----------------------------------------------------------------------c 1530 ! Basic Iterative Solvers with Reverse Communication c 1531 !----------------------------------------------------------------------c 1532 ! This file currently has several basic iterative linear system c 1533 ! solvers. They are: c 1534 ! CG -- Conjugate Gradient Method c 1535 ! CGNR -- Conjugate Gradient Method (Normal Residual equation) c 1536 ! BCG -- Bi-Conjugate Gradient Method c 1537 ! DBCG -- BCG with partial pivoting c 1538 ! BCGSTAB -- BCG stabilized c 1539 ! TFQMR -- Transpose-Free Quasi-Minimum Residual method c 1540 ! FOM -- Full Orthogonalization Method c 1541 ! GMRES -- Generalized Minimum RESidual method c 1542 ! FGMRES -- Flexible version of Generalized Minimum c 1543 ! RESidual method c 1544 ! DQGMRES -- Direct versions of Quasi Generalize Minimum c 1545 ! Residual method c 1546 !----------------------------------------------------------------------c 1547 ! They all have the following calling sequence: 1548 ! subroutine solver(n, rhs, sol, ipar, fpar, w) 1549 ! integer n, ipar(16) 1550 ! real*8 rhs(n), sol(n), fpar(16), w(*) 1551 ! Where 1552 ! (1) 'n' is the size of the linear system, 1553 ! (2) 'rhs' is the right-hand side of the linear system, 1554 ! (3) 'sol' is the solution to the linear system, 1555 ! (4) 'ipar' is an integer parameter array for the reverse 1556 ! communication protocol, 1557 ! (5) 'fpar' is an floating-point parameter array storing 1558 ! information to and from the iterative solvers. 1559 ! (6) 'w' is the work space (size is specified in ipar) 1560 ! 1561 ! They are preconditioned iterative solvers with reverse 1562 ! communication. The preconditioners can be applied from either 1563 ! from left or right or both (specified by ipar(2), see below). 1564 ! 1565 ! Author: Kesheng John Wu (kewu@mail.cs.umn.edu) 1993 1566 ! 1567 ! NOTES: 1568 ! 1569 ! (1) Work space required by each of the iterative solver 1570 ! routines is as follows: 1571 ! CG == 5 * n 1572 ! CGNR == 5 * n 1573 ! BCG == 7 * n 1574 ! DBCG == 11 * n 1575 ! BCGSTAB == 8 * n 1576 ! TFQMR == 11 * n 1577 ! FOM == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) Page 47 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1578 ! GMRES == (n+3)*(m+2) + (m+1)*m/2 (m = ipar(5), default m=15) 1579 ! FGMRES == 2*n*(m+1) + (m+1)*m/2 + 3*m + 2 (m = ipar(5), 1580 ! default m=15) 1581 ! DQGMRES == n + lb * (2*n+4) (lb=ipar(5)+1, default lb = 16) 1582 ! 1583 ! (2) ALL iterative solvers require a user-supplied DOT-product 1584 ! routine named ddot. The prototype of ddot is 1585 ! 1586 ! real*8 function ddot(n,x,y) 1587 ! integer n, ix, iy 1588 ! real*8 x(1+(n-1)*ix), y(1+(n-1)*iy) 1589 ! 1590 ! This interface of ddot is exactly the same as that of 1591 ! DDOT (or SDOT if real == real*8) from BLAS-1. It should have 1592 ! same functionality as DDOT on a single processor machine. On a 1593 ! parallel/distributed environment, each processor can perform 1594 ! DDOT on the data it has, then perform a summation on all the 1595 ! partial results. 1596 ! 1597 ! (3) To use this set of routines under SPMD/MIMD program paradigm, 1598 ! several things are to be noted: (a) 'n' should be the number of 1599 ! vector elements of 'rhs' that is present on the local processor. 1600 ! (b) if RHS(i) is on processor j, it is expected that SOL(i) 1601 ! will be on the same processor, i.e. the vectors are distributed 1602 ! to each processor in the same way. (c) the preconditioning and 1603 ! stopping criteria specifications have to be the same on all 1604 ! processor involved, ipar and fpar have to be the same on each 1605 ! processor. (d) ddot should be replaced by a distributed 1606 ! dot-product function. 1607 ! 1608 ! .................................................................. 1609 ! Reverse Communication Protocols 1610 ! 1611 ! When a reverse-communication routine returns, it could be either 1612 ! that the routine has terminated or it simply requires the caller 1613 ! to perform one matrix-vector multiplication. The possible matrices 1614 ! that involve in the matrix-vector multiplications are: 1615 ! A (the matrix of the linear system), 1616 ! A^T (A transposed), 1617 ! Ml^{-1} (inverse of the left preconditioner), 1618 ! Ml^{-T} (inverse of the left preconditioner transposed), 1619 ! Mr^{-1} (inverse of the right preconditioner), 1620 ! Mr^{-T} (inverse of the right preconditioner transposed). 1621 ! For all the matrix vector multiplication, v = A u. The input and 1622 ! output vectors are supposed to be part of the work space 'w', and 1623 ! the starting positions of them are stored in ipar(8:9), see below. 1624 ! 1625 ! The array 'ipar' is used to store the information about the solver. 1626 ! Here is the list of what each element represents: 1627 ! 1628 ! ipar(1) -- status of the call/return. 1629 ! A call to the solver with ipar(1) == 0 will initialize the 1630 ! iterative solver. On return from the iterative solver, ipar(1) 1631 ! carries the status flag which indicates the condition of the 1632 ! return. The status information is divided into two categories, 1633 ! (1) a positive value indicates the solver requires a matrix-vector 1634 ! multiplication, Page 48 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1635 ! (2) a non-positive value indicates termination of the solver. 1636 ! Here is the current definition: 1637 ! 1 == request a matvec with A, 1638 ! 2 == request a matvec with A^T, 1639 ! 3 == request a left preconditioner solve (Ml^{-1}), 1640 ! 4 == request a left preconditioner transposed solve (Ml^{-T}), 1641 ! 5 == request a right preconditioner solve (Mr^{-1}), 1642 ! 6 == request a right preconditioner transposed solve (Mr^{-T}), 1643 ! 10 == request the caller to perform stopping test, 1644 ! 0 == normal termination of the solver, satisfied the stopping 1645 ! criteria, 1646 ! -1 == termination because iteration number is greater than the 1647 ! preset limit, 1648 ! -2 == return due to insufficient work space, 1649 ! -3 == return due to anticipated break-down / divide by zero, 1650 ! in the case where Arnoldi procedure is used, additional 1651 ! error code can be found in ipar(12), where ipar(12) is 1652 ! the error code of orthogonalization procedure MGSRO: 1653 ! -1: zero input vector 1654 ! -2: input vector contains abnormal numbers 1655 ! -3: input vector is a linear combination of others 1656 ! -4: trianguler system in GMRES/FOM/etc. has nul rank 1657 ! -4 == the values of fpar(1) and fpar(2) are both <= 0, the valid 1658 ! ranges are 0 <= fpar(1) < 1, 0 <= fpar(2), and they can 1659 ! not be zero at the same time 1660 ! -9 == while trying to detect a break-down, an abnormal number is 1661 ! detected. 1662 ! -10 == return due to some non-numerical reasons, e.g. invalid 1663 ! floating-point numbers etc. 1664 ! 1665 ! ipar(2) -- status of the preconditioning: 1666 ! 0 == no preconditioning 1667 ! 1 == left preconditioning only 1668 ! 2 == right preconditioning only 1669 ! 3 == both left and right preconditioning 1670 ! 1671 ! ipar(3) -- stopping criteria (details of this will be 1672 ! discussed later). 1673 ! 1674 ! ipar(4) -- number of elements in the array 'w'. if this is less 1675 ! than the desired size, it will be over-written with the minimum 1676 ! requirement. In which case the status flag ipar(1) = -2. 1677 ! 1678 ! ipar(5) -- size of the Krylov subspace (used by GMRES and its 1679 ! variants), e.g. GMRES(ipar(5)), FGMRES(ipar(5)), 1680 ! DQGMRES(ipar(5)). 1681 ! 1682 ! ipar(6) -- maximum number of matrix-vector multiplies, if not a 1683 ! positive number the iterative solver will run till convergence 1684 ! test is satisfied. 1685 ! 1686 ! ipar(7) -- current number of matrix-vector multiplies. It is 1687 ! incremented after each matrix-vector multiplication. If there 1688 ! is preconditioning, the counter is incremented after the 1689 ! preconditioning associated with each matrix-vector multiplication. 1690 ! 1691 ! ipar(8) -- pointer to the input vector to the requested matrix- Page 49 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1692 ! vector multiplication. 1693 ! 1694 ! ipar(9) -- pointer to the output vector of the requested matrix- 1695 ! vector multiplication. 1696 ! 1697 ! To perform v = A * u, it is assumed that u is w(ipar(8):ipar(8)+n-1) 1698 ! and v is stored as w(ipar(9):ipar(9)+n-1). 1699 ! 1700 ! ipar(10) -- the return address (used to determine where to go to 1701 ! inside the iterative solvers after the caller has performed the 1702 ! requested services). 1703 ! 1704 ! ipar(11) -- the result of the external convergence test 1705 ! On final return from the iterative solvers, this value 1706 ! will be reflected by ipar(1) = 0 (details discussed later) 1707 ! 1708 ! ipar(12) -- error code of MGSRO, it is 1709 ! 1 if the input vector to MGSRO is linear combination 1710 ! of others, 1711 ! 0 if MGSRO was successful, 1712 ! -1 if the input vector to MGSRO is zero, 1713 ! -2 if the input vector contains invalid number. 1714 ! 1715 ! ipar(13) -- number of initializations. During each initilization 1716 ! residual norm is computed directly from M_l(b - A x). 1717 ! 1718 ! ipar(14) to ipar(16) are NOT defined, they are NOT USED by 1719 ! any iterative solver at this time. 1720 ! 1721 ! Information about the error and tolerance are stored in the array 1722 ! FPAR. So are some internal variables that need to be saved from 1723 ! one iteration to the next one. Since the internal variables are 1724 ! not the same for each routine, we only define the common ones. 1725 ! 1726 ! The first two are input parameters: 1727 ! fpar(1) -- the relative tolerance, 1728 ! fpar(2) -- the absolute tolerance (details discussed later), 1729 ! 1730 ! When the iterative solver terminates, 1731 ! fpar(3) -- initial residual/error norm, 1732 ! fpar(4) -- target residual/error norm, 1733 ! fpar(5) -- current residual norm (if available), 1734 ! fpar(6) -- current residual/error norm, 1735 ! fpar(7) -- convergence rate, 1736 ! 1737 ! fpar(8:10) are used by some of the iterative solvers to save some 1738 ! internal information. 1739 ! 1740 ! fpar(11) -- number of floating-point operations. The iterative 1741 ! solvers will add the number of FLOPS they used to this variable, 1742 ! but they do NOT initialize it, nor add the number of FLOPS due to 1743 ! matrix-vector multiplications (since matvec is outside of the 1744 ! iterative solvers). To insure the correct FLOPS count, the 1745 ! caller should set fpar(11) = 0 before invoking the iterative 1746 ! solvers and account for the number of FLOPS from matrix-vector 1747 ! multiplications and preconditioners. 1748 ! Page 50 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1749 ! fpar(12:16) are not used in current implementation. 1750 ! 1751 ! Whether the content of fpar(3), fpar(4) and fpar(6) are residual 1752 ! norms or error norms depends on ipar(3). If the requested 1753 ! convergence test is based on the residual norm, they will be 1754 ! residual norms. If the caller want to test convergence based the 1755 ! error norms (estimated by the norm of the modifications applied 1756 ! to the approximate solution), they will be error norms. 1757 ! Convergence rate is defined by (Fortran 77 statement) 1758 ! fpar(7) = log10(fpar(3) / fpar(6)) / (ipar(7)-ipar(13)) 1759 ! If fpar(7) = 0.5, it means that approximately every 2 (= 1/0.5) 1760 ! steps the residual/error norm decrease by a factor of 10. 1761 ! 1762 ! .................................................................. 1763 ! Stopping criteria, 1764 ! 1765 ! An iterative solver may be terminated due to (1) satisfying 1766 ! convergence test; (2) exceeding iteration limit; (3) insufficient 1767 ! work space; (4) break-down. Checking of the work space is 1768 ! only done in the initialization stage, i.e. when it is called with 1769 ! ipar(1) == 0. A complete convergence test is done after each 1770 ! update of the solutions. Other conditions are monitored 1771 ! continuously. 1772 ! 1773 ! With regard to the number of iteration, when ipar(6) is positive, 1774 ! the current iteration number will be checked against it. If 1775 ! current iteration number is greater the ipar(6) than the solver 1776 ! will return with status -1. If ipar(6) is not positive, the 1777 ! iteration will continue until convergence test is satisfied. 1778 ! 1779 ! Two things may be used in the convergence tests, one is the 1780 ! residual 2-norm, the other one is 2-norm of the change in the 1781 ! approximate solution. The residual and the change in approximate 1782 ! solution are from the preconditioned system (if preconditioning 1783 ! is applied). The DQGMRES and TFQMR use two estimates for the 1784 ! residual norms. The estimates are not accurate, but they are 1785 ! acceptable in most of the cases. Generally speaking, the error 1786 ! of the TFQMR's estimate is less accurate. 1787 ! 1788 ! The convergence test type is indicated by ipar(3). There are four 1789 ! type convergence tests: (1) tests based on the residual norm; 1790 ! (2) tests based on change in approximate solution; (3) caller 1791 ! does not care, the solver choose one from above two on its own; 1792 ! (4) caller will perform the test, the solver should simply continue. 1793 ! Here is the complete definition: 1794 ! -2 == || dx(i) || <= rtol * || rhs || + atol 1795 ! -1 == || dx(i) || <= rtol * || dx(1) || + atol 1796 ! 0 == solver will choose test 1 (next) 1797 ! 1 == || residual || <= rtol * || initial residual || + atol 1798 ! 2 == || residual || <= rtol * || rhs || + atol 1799 ! 999 == caller will perform the test 1800 ! where dx(i) denote the change in the solution at the ith update. 1801 ! ||.|| denotes 2-norm. rtol = fpar(1) and atol = fpar(2). 1802 ! 1803 ! If the caller is to perform the convergence test, the outcome 1804 ! should be stored in ipar(11). 1805 ! ipar(11) = 0 -- failed the convergence test, iterative solver Page 51 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1806 ! should continue 1807 ! ipar(11) = 1 -- satisfied convergence test, iterative solver 1808 ! should perform the clean up job and stop. 1809 ! 1810 ! Upon return with ipar(1) = 10, 1811 ! ipar(8) points to the starting position of the change in 1812 ! solution Sx, where the actual solution of the step is 1813 ! x_j = x_0 + M_r^{-1} Sx. 1814 ! Exception: ipar(8) < 0, Sx = 0. It is mostly used by 1815 ! GMRES and variants to indicate (1) Sx was not necessary, 1816 ! (2) intermediate result of Sx is not computed. 1817 ! ipar(9) points to the starting position of a work vector that 1818 ! can be used by the caller. 1819 ! 1820 ! NOTE: the caller should allow the iterative solver to perform 1821 ! clean up job after the external convergence test is satisfied, 1822 ! since some of the iterative solvers do not directly 1823 ! update the 'sol' array. A typical clean-up stage includes 1824 ! performing the final update of the approximate solution and 1825 ! computing the convergence information (e.g. values of fpar(3:7)). 1826 ! 1827 ! NOTE: fpar(4) and fpar(6) are not set by the accelerators (the 1828 ! routines implemented here) if ipar(3) = 999. 1829 ! 1830 ! .................................................................. 1831 ! Usage: 1832 ! 1833 ! To start solving a linear system, the user needs to specify 1834 ! first 6 elements of the ipar, and first 2 elements of fpar. 1835 ! The user may optionally set fpar(11) = 0 if one wants to count 1836 ! the number of floating-point operations. (Note: the iterative 1837 ! solvers will only add the floating-point operations inside 1838 ! themselves, the caller will have to add the FLOPS from the 1839 ! matrix-vector multiplication routines and the preconditioning 1840 ! routines in order to account for all the arithmetic operations.) 1841 ! 1842 ! Here is an example: 1843 ! ipar(1) = 0 ! always 0 to start an iterative solver 1844 ! ipar(2) = 2 ! right preconditioning 1845 ! ipar(3) = 1 ! use convergence test scheme 1 1846 ! ipar(4) = 10000 ! the 'w' has 10,000 elements 1847 ! ipar(5) = 10 ! use *GMRES(10) (e.g. FGMRES(10)) 1848 ! ipar(6) = 100 ! use at most 100 matvec's 1849 ! fpar(1) = 1.0E-6 ! relative tolerance 1.0E-6 1850 ! fpar(2) = 1.0E-10 ! absolute tolerance 1.0E-10 1851 ! fpar(11) = 0.0 ! clearing the FLOPS counter 1852 ! 1853 ! After the above specifications, one can start to call an iterative 1854 ! solver, say BCG. Here is a piece of pseudo-code showing how it can 1855 ! be done, 1856 ! 1857 ! 10 call bcg(n,rhs,sol,ipar,fpar,w) 1858 ! if (ipar(1).eq.1) then 1859 ! call amux(n,w(ipar(8)),w(ipar(9)),a,ja,ia) 1860 ! goto 10 1861 ! else if (ipar(1).eq.2) then 1862 ! call atmux(n,w(ipar(8)),w(ipar(9)),a,ja,ia) Page 52 Source Listing W3XYPFSFCT2 2014-09-16 16:49 w3profsmd.f90 1863 ! goto 10 1864 ! else if (ipar(1).eq.3) then 1865 ! left preconditioner solver 1866 ! goto 10 1867 ! else if (ipar(1).eq.4) then 1868 ! left preconditioner transposed solve 1869 ! goto 10 1870 ! else if (ipar(1).eq.5) then 1871 ! right preconditioner solve 1872 ! goto 10 1873 ! else if (ipar(1).eq.6) then 1874 ! right preconditioner transposed solve 1875 ! goto 10 1876 ! else if (ipar(1).eq.10) then 1877 ! call my own stopping test routine 1878 ! goto 10 1879 ! else if (ipar(1).gt.0) then 1880 ! ipar(1) is an unspecified code 1881 ! else 1882 ! the iterative solver terminated with code = ipar(1) 1883 ! endif 1884 ! 1885 ! This segment of pseudo-code assumes the matrix is in CSR format, 1886 ! AMUX and ATMUX are two routines from the SPARSKIT MATVEC module. 1887 ! They perform matrix-vector multiplications for CSR matrices, 1888 ! where w(ipar(8)) is the first element of the input vectors to the 1889 ! two routines, and w(ipar(9)) is the first element of the output 1890 ! vectors from them. For simplicity, we did not show the name of 1891 ! the routine that performs the preconditioning operations or the 1892 ! convergence tests. 1893 !----------------------------------------------------------------------- 1894 subroutine bcgstab(n, rhs, sol, ipar, fpar, w) 1895 implicit none 1896 integer n, ipar(16) 1897 real*8 rhs(n), sol(n), fpar(16), w(n,8) 1898 !----------------------------------------------------------------------- 1899 ! BCGSTAB --- Bi Conjugate Gradient stabilized (BCGSTAB) 1900 ! This is an improved BCG routine. (1) no matrix transpose is 1901 ! involved. (2) the convergence is smoother. 1902 ! 1903 ! Algorithm: 1904 ! Initialization - r = b - A x, r0 = r, p = r, rho = (r0, r), 1905 ! Iterate - 1906 ! (1) v = A p 1907 ! (2) alpha = rho / (r0, v) 1908 ! (3) s = r - alpha v 1909 ! (4) t = A s 1910 ! (5) omega = (t, s) / (t, t) 1911 ! (6) x = x + alpha * p + omega * s 1912 ! (7) r = s - omega * t 1913 ! convergence test goes here 1914 ! (8) beta = rho, rho = (r0, r), beta = rho * alpha / (beta * omega) 1915 ! p = r + beta * (p - omega * v) 1916 ! 1917 ! in this routine, before successful return, the fpar's are 1918 ! fpar(3) == initial (preconditionied-)residual norm 1919 ! fpar(4) == target (preconditionied-)residual norm Page 53 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 1920 ! fpar(5) == current (preconditionied-)residual norm 1921 ! fpar(6) == current residual norm or error 1922 ! fpar(7) == current rho (rhok = ) 1923 ! fpar(8) == alpha 1924 ! fpar(9) == omega 1925 ! 1926 ! Usage of the work space W 1927 ! w(:, 1) = r0, the initial residual vector 1928 ! w(:, 2) = r, current residual vector 1929 ! w(:, 3) = s 1930 ! w(:, 4) = t 1931 ! w(:, 5) = v 1932 ! w(:, 6) = p 1933 ! w(:, 7) = tmp, used in preconditioning, etc. 1934 ! w(:, 8) = delta x, the correction to the answer is accumulated 1935 ! here, so that the right-preconditioning may be applied 1936 ! at the end 1937 !----------------------------------------------------------------------- 1938 ! external routines used 1939 ! 1940 real*8 ddot 1941 logical stopbis, brkdn 1942 external ddot, stopbis, brkdn 1943 ! 1944 real*8 one 1945 parameter(one=1.0D0) 1946 ! 1947 ! local variables 1948 ! 1949 integer i 1950 real*8 alpha,beta,rho,omega 1951 logical lp, rp 1952 save lp, rp 1953 ! 1954 ! where to go 1955 ! 1956 if (ipar(1).gt.0) then 1957 goto (10, 20, 40, 50, 60, 70, 80, 90, 100, 110) ipar(10) 1958 else if (ipar(1).lt.0) then 1959 goto 900 1960 endif 1961 ! 1962 ! call the initialization routine 1963 ! 1964 call bisinit(ipar,fpar,8*n,1,lp,rp,w) 1965 if (ipar(1).lt.0) return 1966 ! 1967 ! perform a matvec to compute the initial residual 1968 ! 1969 ipar(1) = 1 1970 ipar(8) = 1 1971 ipar(9) = 1 + n 1972 do i = 1, n 1973 w(i,1) = sol(i) 1974 enddo 1975 ipar(10) = 1 1976 return Page 54 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 1977 10 ipar(7) = ipar(7) + 1 1978 ipar(13) = ipar(13) + 1 1979 do i = 1, n 1980 w(i,1) = rhs(i) - w(i,2) 1981 enddo 1982 fpar(11) = fpar(11) + n 1983 if (lp) then 1984 ipar(1) = 3 1985 ipar(10) = 2 1986 return 1987 endif 1988 ! 1989 20 if (lp) then 1990 do i = 1, n 1991 w(i,1) = w(i,2) 1992 w(i,6) = w(i,2) 1993 enddo 1994 else 1995 do i = 1, n 1996 w(i,2) = w(i,1) 1997 w(i,6) = w(i,1) 1998 enddo 1999 endif 2000 ! 2001 fpar(7) = ddot(n,w,w) 2002 fpar(11) = fpar(11) + 2 * n 2003 fpar(5) = sqrt(fpar(7)) 2004 fpar(3) = fpar(5) 2005 if (abs(ipar(3)).eq.2) then 2006 fpar(4) = fpar(1) * sqrt(ddot(n,rhs,rhs)) + fpar(2) 2007 fpar(11) = fpar(11) + 2 * n 2008 else if (ipar(3).ne.999) then 2009 fpar(4) = fpar(1) * fpar(3) + fpar(2) 2010 endif 2011 if (ipar(3).ge.0) fpar(6) = fpar(5) 2012 if (ipar(3).ge.0 .and. fpar(5).le.fpar(4) .and. ipar(3).ne.999) then 2013 goto 900 2014 endif 2015 ! 2016 ! beginning of the iterations 2017 ! 2018 ! Step (1), v = A p 2019 30 if (rp) then 2020 ipar(1) = 5 2021 ipar(8) = 5*n+1 2022 if (lp) then 2023 ipar(9) = 4*n + 1 2024 else 2025 ipar(9) = 6*n + 1 2026 endif 2027 ipar(10) = 3 2028 return 2029 endif 2030 ! 2031 40 ipar(1) = 1 2032 if (rp) then 2033 ipar(8) = ipar(9) Page 55 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 2034 else 2035 ipar(8) = 5*n+1 2036 endif 2037 if (lp) then 2038 ipar(9) = 6*n + 1 2039 else 2040 ipar(9) = 4*n + 1 2041 endif 2042 ipar(10) = 4 2043 return 2044 50 if (lp) then 2045 ipar(1) = 3 2046 ipar(8) = ipar(9) 2047 ipar(9) = 4*n + 1 2048 ipar(10) = 5 2049 return 2050 endif 2051 ! 2052 60 ipar(7) = ipar(7) + 1 2053 ! 2054 ! step (2) 2055 alpha = ddot(n,w(1,1),w(1,5)) 2056 fpar(11) = fpar(11) + 2 * n 2057 if (brkdn(alpha, ipar)) goto 900 2058 alpha = fpar(7) / alpha 2059 fpar(8) = alpha 2060 ! 2061 ! step (3) 2062 do i = 1, n 2063 w(i,3) = w(i,2) - alpha * w(i,5) 2064 enddo 2065 fpar(11) = fpar(11) + 2 * n 2066 ! 2067 ! Step (4): the second matvec -- t = A s 2068 ! 2069 if (rp) then 2070 ipar(1) = 5 2071 ipar(8) = n+n+1 2072 if (lp) then 2073 ipar(9) = ipar(8)+n 2074 else 2075 ipar(9) = 6*n + 1 2076 endif 2077 ipar(10) = 6 2078 return 2079 endif 2080 ! 2081 70 ipar(1) = 1 2082 if (rp) then 2083 ipar(8) = ipar(9) 2084 else 2085 ipar(8) = n+n+1 2086 endif 2087 if (lp) then 2088 ipar(9) = 6*n + 1 2089 else 2090 ipar(9) = 3*n + 1 Page 56 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 2091 endif 2092 ipar(10) = 7 2093 return 2094 80 if (lp) then 2095 ipar(1) = 3 2096 ipar(8) = ipar(9) 2097 ipar(9) = 3*n + 1 2098 ipar(10) = 8 2099 return 2100 endif 2101 90 ipar(7) = ipar(7) + 1 2102 ! 2103 ! step (5) 2104 omega = ddot(n,w(1,4),w(1,4)) 2105 fpar(11) = fpar(11) + n + n 2106 if (brkdn(omega,ipar)) goto 900 2107 omega = ddot(n,w(1,4),w(1,3)) / omega 2108 fpar(11) = fpar(11) + n + n 2109 if (brkdn(omega,ipar)) goto 900 2110 fpar(9) = omega 2111 alpha = fpar(8) 2112 ! 2113 ! step (6) and (7) 2114 do i = 1, n 2115 w(i,7) = alpha * w(i,6) + omega * w(i,3) 2116 w(i,8) = w(i,8) + w(i,7) 2117 w(i,2) = w(i,3) - omega * w(i,4) 2118 enddo 2119 fpar(11) = fpar(11) + 6 * n + 1 2120 ! 2121 ! convergence test 2122 if (ipar(3).eq.999) then 2123 ipar(1) = 10 2124 ipar(8) = 7*n + 1 2125 ipar(9) = 6*n + 1 2126 ipar(10) = 9 2127 return 2128 endif 2129 if (stopbis(n,ipar,2,fpar,w(1,2),w(1,7),one)) goto 900 2130 100 if (ipar(3).eq.999.and.ipar(11).eq.1) goto 900 2131 ! 2132 ! step (8): computing new p and rho 2133 ! 2134 rho = fpar(7) 2135 fpar(7) = ddot(n,w(1,2),w(1,1)) 2136 omega = fpar(9) 2137 beta = fpar(7) * fpar(8) / (fpar(9) * rho) 2138 do i = 1, n 2139 w(i,6) = w(i,2) + beta * (w(i,6) - omega * w(i,5)) 2140 enddo 2141 fpar(11) = fpar(11) + 6 * n + 3 2142 if (brkdn(fpar(7),ipar)) goto 900 2143 ! 2144 ! end of an iteration 2145 ! 2146 goto 30 2147 ! Page 57 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 2148 ! some clean up job to do 2149 ! 2150 900 if (rp) then 2151 if (ipar(1).lt.0) ipar(12) = ipar(1) 2152 ipar(1) = 5 2153 ipar(8) = 7*n + 1 2154 ipar(9) = ipar(8) - n 2155 ipar(10) = 10 2156 return 2157 endif 2158 2159 110 if (rp) then 2160 call tidycg(n,ipar,fpar,sol,w(1,7)) 2161 else 2162 call tidycg(n,ipar,fpar,sol,w(1,8)) 2163 endif 2164 ! 2165 return 2166 !-----end-of-bcgstab 2167 end ENTRY POINTS Name bcgstab_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 1977 1957 100 Label 2130 1957 110 Label 2159 1957 20 Label 1989 1957 30 Label 2019 2146 40 Label 2031 1957 50 Label 2044 1957 60 Label 2052 1957 70 Label 2081 1957 80 Label 2094 1957 90 Label 2101 1957 900 Label 2150 1959,2013,2057,2106,2109,2129,2130 ,2142 ABS Func 2005 scalar 2005 ALPHA Local 1950 R(8) 8 scalar 2055,2057,2058,2059,2063,2111,2115 BCGSTAB Subr 1894 BETA Local 1950 R(8) 8 scalar 2137,2139 BISINIT Subr 1964 1964 BRKDN Func 1941 L(4) 4 scalar 2057,2106,2109,2142 DDOT Func 1940 R(8) 8 scalar 2001,2006,2055,2104,2107,2135 FPAR Dummy 1894 R(8) 8 1 16 ARG,INOUT 1964,1982,2001,2002,2003,2004,2006 ,2007,2009,2011,2012,2056,2058,205 9,2065,2105,2108,2110,2111,2119,21 29,2134,2135,2136,2137,2141,2142,2 Page 58 Source Listing BCGSTAB 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References 160,2162 I Local 1949 I(4) 4 scalar 1972,1973,1979,1980,1990,1991,1992 ,1995,1996,1997,2062,2063,2114,211 5,2116,2117,2138,2139 IPAR Dummy 1894 I(4) 4 1 16 ARG,INOUT 1956,1957,1958,1964,1965,1969,1970 ,1971,1975,1977,1978,1984,1985,200 5,2008,2011,2012,2020,2021,2023,20 25,2027,2031,2033,2035,2038,2040,2 042,2045,2046,2047,2048,2052,2057, 2070,2071,2073,2075,2077,2081,2083 ,2085,2088,2090,2092,2095,2096,209 7,2098,2101,2106,2109,2122,2123,21 24,2125,2126,2129,2130,2142,2151,2 152,2153,2154,2155,2160,2162 LP Local 1951 L(4) 4 scalar 1964,1983,1989,2022,2037,2044,2072 ,2087,2094 N Dummy 1894 I(4) 4 scalar ARG,INOUT 1897,1964,1971,1972,1979,1982,1990 ,1995,2001,2002,2006,2007,2021,202 3,2025,2035,2038,2040,2047,2055,20 56,2062,2065,2071,2073,2075,2085,2 088,2090,2097,2104,2105,2107,2108, 2114,2119,2124,2125,2129,2135,2138 ,2141,2153,2154,2160,2162 OMEGA Local 1950 R(8) 8 scalar 2104,2106,2107,2109,2110,2115,2117 ,2136,2139 ONE Param 1944 R(8) 8 scalar 2129 RHO Local 1950 R(8) 8 scalar 2134,2137 RHS Dummy 1894 R(8) 8 1 0 ARG,INOUT 1980,2006 RP Local 1951 L(4) 4 scalar 1964,2019,2032,2069,2082,2150,2159 SOL Dummy 1894 R(8) 8 1 0 ARG,INOUT 1973,2160,2162 SQRT Func 2003 scalar 2003,2006 STOPBIS Func 1941 L(4) 4 scalar 2129 TIDYCG Subr 2160 2160,2162 W Dummy 1894 R(8) 8 2 0 ARG,INOUT 1964,1973,1980,1991,1992,1996,1997 ,2001,2055,2063,2104,2107,2115,211 6,2117,2129,2135,2139,2160,2162 Page 59 Source Listing BCGSTAB 2014-09-16 16:49 w3profsmd.f90 2168 !----------------------------------------------------------------------- 2169 subroutine gmres(n, rhs, sol, ipar, fpar, w) 2170 implicit none 2171 integer n, ipar(16) 2172 real*8 rhs(n), sol(n), fpar(16), w(*) 2173 !----------------------------------------------------------------------- 2174 ! This a version of GMRES implemented with reverse communication. 2175 ! It is a simple restart version of the GMRES algorithm. 2176 ! 2177 ! ipar(5) == the dimension of the Krylov subspace 2178 ! after every ipar(5) iterations, the GMRES will restart with 2179 ! the updated solution and recomputed residual vector. 2180 ! 2181 ! the space of the `w' is used as follows: 2182 ! (1) the basis for the Krylov subspace, size n*(m+1); 2183 ! (2) the Hessenberg matrix, only the upper triangular 2184 ! portion of the matrix is stored, size (m+1)*m/2 + 1 2185 ! (3) three vectors, all are of size m, they are 2186 ! the cosine and sine of the Givens rotations, the third one holds 2187 ! the residuals, it is of size m+1. 2188 ! 2189 ! TOTAL SIZE REQUIRED == (n+3)*(m+2) + (m+1)*m/2 2190 ! Note: m == ipar(5). The default value for this is 15 if 2191 ! ipar(5) <= 1. 2192 !----------------------------------------------------------------------- 2193 ! external functions used 2194 ! 2195 real*8 ddot 2196 external ddot 2197 ! 2198 real*8 one, zero 2199 parameter(one=1.0D0, zero=0.0D0) 2200 ! 2201 ! local variables, ptr and p2 are temporary pointers, 2202 ! hess points to the Hessenberg matrix, 2203 ! vc, vs point to the cosines and sines of the Givens rotations 2204 ! vrn points to the vectors of residual norms, more precisely 2205 ! the right hand side of the least square problem solved. 2206 ! 2207 integer i,ii,idx,k,m,ptr,p2,hess,vc,vs,vrn 2208 real*8 alpha, c, s 2209 logical lp, rp 2210 save 2211 ! 2212 ! check the status of the call 2213 ! 2214 if (ipar(1).le.0) ipar(10) = 0 2215 goto (10, 20, 30, 40, 50, 60, 70) ipar(10) 2216 ! 2217 ! initialization 2218 ! 2219 if (ipar(5).le.1) then 2220 m = 15 2221 else 2222 m = ipar(5) 2223 endif 2224 idx = n * (m+1) Page 60 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2225 hess = idx + n 2226 vc = hess + (m+1) * m / 2 + 1 2227 vs = vc + m 2228 vrn = vs + m 2229 i = vrn + m + 1 2230 call bisinit(ipar,fpar,i,1,lp,rp,w) 2231 if (ipar(1).lt.0) return 2232 ! 2233 ! request for matrix vector multiplication A*x in the initialization 2234 ! 2235 100 ipar(1) = 1 2236 ipar(8) = n+1 2237 ipar(9) = 1 2238 ipar(10) = 1 2239 k = 0 2240 do i = 1, n 2241 w(n+i) = sol(i) 2242 enddo 2243 return 2244 10 ipar(7) = ipar(7) + 1 2245 ipar(13) = ipar(13) + 1 2246 if (lp) then 2247 do i = 1, n 2248 w(n+i) = rhs(i) - w(i) 2249 enddo 2250 ipar(1) = 3 2251 ipar(10) = 2 2252 return 2253 else 2254 do i = 1, n 2255 w(i) = rhs(i) - w(i) 2256 enddo 2257 endif 2258 fpar(11) = fpar(11) + n 2259 ! 2260 20 alpha = sqrt(ddot(n,w,w)) 2261 fpar(11) = fpar(11) + 2*n 2262 if (ipar(7).eq.1 .and. ipar(3).ne.999) then 2263 if (abs(ipar(3)).eq.2) then 2264 fpar(4) = fpar(1) * sqrt(ddot(n,rhs,rhs)) + fpar(2) 2265 fpar(11) = fpar(11) + 2*n 2266 else 2267 fpar(4) = fpar(1) * alpha + fpar(2) 2268 endif 2269 fpar(3) = alpha 2270 endif 2271 fpar(5) = alpha 2272 w(vrn+1) = alpha 2273 if (alpha.le.fpar(4) .and. ipar(3).ge.0 .and. ipar(3).ne.999) then 2274 ipar(1) = 0 2275 fpar(6) = alpha 2276 goto 300 2277 endif 2278 alpha = one / alpha 2279 do ii = 1, n 2280 w(ii) = alpha * w(ii) 2281 enddo Page 61 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2282 fpar(11) = fpar(11) + n 2283 ! 2284 ! request for (1) right preconditioning 2285 ! (2) matrix vector multiplication 2286 ! (3) left preconditioning 2287 ! 2288 110 k = k + 1 2289 if (rp) then 2290 ipar(1) = 5 2291 ipar(8) = k*n - n + 1 2292 if (lp) then 2293 ipar(9) = k*n + 1 2294 else 2295 ipar(9) = idx + 1 2296 endif 2297 ipar(10) = 3 2298 return 2299 endif 2300 ! 2301 30 ipar(1) = 1 2302 if (rp) then 2303 ipar(8) = ipar(9) 2304 else 2305 ipar(8) = (k-1)*n + 1 2306 endif 2307 if (lp) then 2308 ipar(9) = idx + 1 2309 else 2310 ipar(9) = 1 + k*n 2311 endif 2312 ipar(10) = 4 2313 return 2314 ! 2315 40 if (lp) then 2316 ipar(1) = 3 2317 ipar(8) = ipar(9) 2318 ipar(9) = k*n + 1 2319 ipar(10) = 5 2320 return 2321 endif 2322 ! 2323 ! Modified Gram-Schmidt orthogonalization procedure 2324 ! temporary pointer 'ptr' is pointing to the current column of the 2325 ! Hessenberg matrix. 'p2' points to the new basis vector 2326 ! 2327 50 ipar(7) = ipar(7) + 1 2328 ptr = k * (k - 1) / 2 + hess 2329 p2 = ipar(9) 2330 call mgsro(.false.,n,n,k+1,k+1,fpar(11),w,w(ptr+1), & 2331 & ipar(12)) 2332 if (ipar(12).lt.0) goto 200 2333 ! 2334 ! apply previous Givens rotations and generate a new one to eliminate 2335 ! the subdiagonal element. 2336 ! 2337 p2 = ptr + 1 2338 do i = 1, k-1 Page 62 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2339 ptr = p2 2340 p2 = p2 + 1 2341 alpha = w(ptr) 2342 c = w(vc+i) 2343 s = w(vs+i) 2344 w(ptr) = c * alpha + s * w(p2) 2345 w(p2) = c * w(p2) - s * alpha 2346 enddo 2347 call givens(w(p2), w(p2+1), c, s) 2348 w(vc+k) = c 2349 w(vs+k) = s 2350 p2 = vrn + k 2351 alpha = - s * w(p2) 2352 w(p2) = c * w(p2) 2353 w(p2+1) = alpha 2354 ! 2355 ! end of one Arnoldi iteration, alpha will store the estimated 2356 ! residual norm at current stage 2357 ! 2358 fpar(11) = fpar(11) + 6*k + 2 2359 alpha = abs(alpha) 2360 fpar(5) = alpha 2361 if (k.lt.m .and. .not.(ipar(3).ge.0 .and. alpha.le.fpar(4)) & 2362 & .and. (ipar(6).le.0 .or. ipar(7).lt.ipar(6))) goto 110 2363 ! 2364 ! update the approximate solution, first solve the upper triangular 2365 ! system, temporary pointer ptr points to the Hessenberg matrix, 2366 ! p2 points to the right-hand-side (also the solution) of the system. 2367 ! 2368 200 ptr = hess + k * (k + 1) / 2 2369 p2 = vrn + k 2370 if (w(ptr).eq.zero) then 2371 ! 2372 ! if the diagonal elements of the last column is zero, reduce k by 1 2373 ! so that a smaller trianguler system is solved [It should only 2374 ! happen when the matrix is singular, and at most once!] 2375 ! 2376 k = k - 1 2377 if (k.gt.0) then 2378 goto 200 2379 else 2380 ipar(1) = -3 2381 ipar(12) = -4 2382 goto 300 2383 endif 2384 endif 2385 w(p2) = w(p2) / w(ptr) 2386 do i = k-1, 1, -1 2387 ptr = ptr - i - 1 2388 do ii = 1, i 2389 w(vrn+ii) = w(vrn+ii) - w(p2) * w(ptr+ii) 2390 enddo 2391 p2 = p2 - 1 2392 w(p2) = w(p2) / w(ptr) 2393 enddo 2394 ! 2395 do ii = 1, n Page 63 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2396 w(ii) = w(ii) * w(p2) 2397 enddo 2398 do i = 1, k-1 2399 ptr = i*n 2400 p2 = p2 + 1 2401 do ii = 1, n 2402 w(ii) = w(ii) + w(p2) * w(ptr+ii) 2403 enddo 2404 enddo 2405 fpar(11) = fpar(11) + 2*k*n - n + k*(k+1) 2406 ! 2407 if (rp) then 2408 ipar(1) = 5 2409 ipar(8) = 1 2410 ipar(9) = idx + 1 2411 ipar(10) = 6 2412 return 2413 endif 2414 ! 2415 60 if (rp) then 2416 do i = 1, n 2417 sol(i) = sol(i) + w(idx+i) 2418 enddo 2419 else 2420 do i = 1, n 2421 sol(i) = sol(i) + w(i) 2422 enddo 2423 endif 2424 fpar(11) = fpar(11) + n 2425 ! 2426 ! process the complete stopping criteria 2427 ! 2428 if (ipar(3).eq.999) then 2429 ipar(1) = 10 2430 ipar(8) = -1 2431 ipar(9) = idx + 1 2432 ipar(10) = 7 2433 return 2434 else if (ipar(3).lt.0) then 2435 if (ipar(7).le.m+1) then 2436 fpar(3) = abs(w(vrn+1)) 2437 if (ipar(3).eq.-1) fpar(4) = fpar(1)*fpar(3)+fpar(2) 2438 endif 2439 fpar(6) = abs(w(vrn+k)) 2440 else 2441 fpar(6) = fpar(5) 2442 endif 2443 ! 2444 ! do we need to restart ? 2445 ! 2446 70 if (ipar(12).ne.0) then 2447 ipar(1) = -3 2448 goto 300 2449 endif 2450 if ((ipar(7).lt.ipar(6) .or. ipar(6).le.0) .and. ((ipar(3).eq.999.and.ipar(11).eq.0) .or. & 2451 & (ipar(3).ne.999.and.fpar(6).gt.fpar(4)))) goto 100 2452 ! Page 64 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2453 ! termination, set error code, compute convergence rate 2454 ! 2455 if (ipar(1).gt.0) then 2456 if (ipar(3).eq.999 .and. ipar(11).eq.1) then 2457 ipar(1) = 0 2458 else if (ipar(3).ne.999 .and. fpar(6).le.fpar(4)) then 2459 ipar(1) = 0 2460 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then 2461 ipar(1) = -1 2462 else 2463 ipar(1) = -10 2464 endif 2465 endif 2466 300 if (fpar(3).ne.zero .and. fpar(6).ne.zero .and. & 2467 & ipar(7).gt.ipar(13)) then 2468 fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) 2469 else 2470 fpar(7) = zero 2471 endif 2472 return 2473 end ENTRY POINTS Name gmres_ Page 65 Source Listing GMRES 2014-09-16 16:49 Symbol Table w3profsmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 2244 2215 100 Label 2235 2451 110 Label 2288 2362 20 Label 2260 2215 200 Label 2368 2332,2378 30 Label 2301 2215 300 Label 2466 2276,2382,2448 40 Label 2315 2215 50 Label 2327 2215 60 Label 2415 2215 70 Label 2446 2215 ABS Func 2263 scalar 2263,2359,2436,2439 ALPHA Local 2208 R(8) 8 scalar 2260,2267,2269,2271,2272,2273,2275 ,2278,2280,2341,2344,2345,2351,235 3,2359,2360,2361 BISINIT Subr 2230 2230 C Local 2208 R(8) 8 scalar 2342,2344,2345,2347,2348,2352 DBLE Func 2468 scalar 2468 DDOT Func 2195 R(8) 8 scalar 2260,2264 FPAR Dummy 2169 R(8) 8 1 16 ARG,INOUT 2230,2258,2261,2264,2265,2267,2269 ,2271,2273,2275,2282,2330,2358,236 0,2361,2405,2424,2436,2437,2439,24 41,2451,2458,2466,2468,2470 GIVENS Subr 2347 2347 GMRES Subr 2169 HESS Local 2207 I(4) 4 scalar 2225,2226,2328,2368 I Local 2207 I(4) 4 scalar 2229,2230,2240,2241,2247,2248,2254 ,2255,2338,2342,2343,2386,2387,238 8,2398,2399,2416,2417,2420,2421 IDX Local 2207 I(4) 4 scalar 2224,2225,2295,2308,2410,2417,2431 II Local 2207 I(4) 4 scalar 2279,2280,2388,2389,2395,2396,2401 ,2402 IPAR Dummy 2169 I(4) 4 1 16 ARG,INOUT 2214,2215,2219,2222,2230,2231,2235 ,2236,2237,2238,2244,2245,2250,225 1,2262,2263,2273,2274,2290,2291,22 93,2295,2297,2301,2303,2305,2308,2 310,2312,2316,2317,2318,2319,2327, 2329,2331,2332,2361,2362,2380,2381 ,2408,2409,2410,2411,2428,2429,243 0,2431,2432,2434,2435,2437,2446,24 47,2450,2451,2455,2456,2457,2458,2 459,2460,2461,2463,2467,2468 K Local 2207 I(4) 4 scalar 2239,2288,2291,2293,2305,2310,2318 ,2328,2330,2338,2348,2349,2350,235 8,2361,2368,2369,2376,2377,2386,23 98,2405,2439 LOG10 Func 2468 scalar 2468 LP Local 2209 L(4) 4 scalar 2230,2246,2292,2307,2315 M Local 2207 I(4) 4 scalar 2220,2222,2224,2226,2227,2228,2229 ,2361,2435 MGSRO Subr 2330 2330 Page 66 Source Listing GMRES 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References N Dummy 2169 I(4) 4 scalar ARG,INOUT 2172,2224,2225,2236,2240,2241,2247 ,2248,2254,2258,2260,2261,2264,226 5,2279,2282,2291,2293,2305,2310,23 18,2330,2395,2399,2401,2405,2416,2 420,2424 ONE Param 2198 R(8) 8 scalar 2278 P2 Local 2207 I(4) 4 scalar 2329,2337,2339,2340,2344,2345,2347 ,2350,2351,2352,2353,2369,2385,238 9,2391,2392,2396,2400,2402 PTR Local 2207 I(4) 4 scalar 2328,2330,2337,2339,2341,2344,2368 ,2370,2385,2387,2389,2392,2399,240 2 RHS Dummy 2169 R(8) 8 1 0 ARG,INOUT 2248,2255,2264 RP Local 2209 L(4) 4 scalar 2230,2289,2302,2407,2415 S Local 2208 R(8) 8 scalar 2343,2344,2345,2347,2349,2351 SOL Dummy 2169 R(8) 8 1 0 ARG,INOUT 2241,2417,2421 SQRT Func 2260 scalar 2260,2264 VC Local 2207 I(4) 4 scalar 2226,2227,2342,2348 VRN Local 2207 I(4) 4 scalar 2228,2229,2272,2350,2369,2389,2436 ,2439 VS Local 2207 I(4) 4 scalar 2227,2228,2343,2349 W Dummy 2169 R(8) 8 1 0 ARG,INOUT 2230,2241,2248,2255,2260,2272,2280 ,2330,2341,2342,2343,2344,2345,234 7,2348,2349,2351,2352,2353,2370,23 85,2389,2392,2396,2402,2417,2421,2 436,2439 ZERO Param 2198 R(8) 8 scalar 2370,2466,2470 Page 67 Source Listing GMRES 2014-09-16 16:49 w3profsmd.f90 2474 !-----end-of-gmres 2475 !----------------------------------------------------------------------- 2476 subroutine implu(np,umm,beta,ypiv,u,permut,full) 2477 real*8 umm,beta,ypiv(*),u(*),x, xpiv 2478 logical full, perm, permut(*) 2479 integer np,k,npm1 2480 !----------------------------------------------------------------------- 2481 ! performs implicitly one step of the lu factorization of a 2482 ! banded hessenberg matrix. 2483 !----------------------------------------------------------------------- 2484 if (np .le. 1) goto 12 2485 npm1 = np - 1 2486 ! 2487 ! -- perform previous step of the factorization- 2488 ! 2489 do 6 k=1,npm1 2490 if (.not. permut(k)) goto 5 2491 x=u(k) 2492 u(k) = u(k+1) 2493 u(k+1) = x 2494 5 u(k+1) = u(k+1) - ypiv(k)*u(k) 2495 6 continue 2496 !----------------------------------------------------------------------- 2497 ! now determine pivotal information to be used in the next call 2498 !----------------------------------------------------------------------- 2499 12 umm = u(np) 2500 perm = (beta .gt. abs(umm)) 2501 if (.not. perm) goto 4 2502 xpiv = umm / beta 2503 u(np) = beta 2504 goto 8 2505 4 xpiv = beta/umm 2506 8 permut(np) = perm 2507 ypiv(np) = xpiv 2508 if (.not. full) return 2509 ! shift everything up if full... 2510 do 7 k=1,npm1 2511 ypiv(k) = ypiv(k+1) 2512 permut(k) = permut(k+1) 2513 7 continue 2514 return 2515 !-----end-of-implu 2516 end Page 68 Source Listing IMPLU 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name implu_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 12 Label 2499 2484 4 Label 2505 2501 5 Label 2494 2490 6 Label 2495 2489 7 Label 2513 2510 8 Label 2506 2504 ABS Func 2500 scalar 2500 BETA Dummy 2476 R(8) 8 scalar ARG,INOUT 2500,2502,2503,2505 FULL Dummy 2476 L(4) 4 scalar ARG,INOUT 2508 IMPLU Subr 2476 K Local 2479 I(4) 4 scalar 2489,2490,2491,2492,2493,2494,2510 ,2511,2512 NP Dummy 2476 I(4) 4 scalar ARG,INOUT 2484,2485,2499,2503,2506,2507 NPM1 Local 2479 I(4) 4 scalar 2485,2489,2510 PERM Local 2478 L(4) 4 scalar 2500,2501,2506 PERMUT Dummy 2476 L(4) 4 1 0 ARG,INOUT 2490,2506,2512 U Dummy 2476 R(8) 8 1 0 ARG,INOUT 2491,2492,2493,2494,2499,2503 UMM Dummy 2476 R(8) 8 scalar ARG,INOUT 2499,2500,2502,2505 X Local 2477 R(8) 8 scalar 2491,2493 XPIV Local 2477 R(8) 8 scalar 2502,2505,2507 YPIV Dummy 2476 R(8) 8 1 0 ARG,INOUT 2494,2507,2511 Page 69 Source Listing IMPLU 2014-09-16 16:49 w3profsmd.f90 2517 !----------------------------------------------------------------------- 2518 subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) 2519 implicit none 2520 2521 integer :: k,np,n,npm1,j,ju,indp,lbp 2522 real*8 :: p(n,lbp), y(*), u(*), usav(*), x, flops 2523 2524 !----------------------------------------------------------------------- 2525 ! updates the conjugate directions p given the upper part of the 2526 ! banded upper triangular matrix u. u contains the non zero 2527 ! elements of the column of the triangular matrix.. 2528 !----------------------------------------------------------------------- 2529 real*8 zero 2530 parameter(zero=0.0D0) 2531 ! 2532 npm1=np-1 2533 if (np .le. 1) goto 12 2534 j=indp 2535 ju = npm1 2536 10 if (j .le. 0) j=lbp 2537 x = u(ju) /usav(j) 2538 if (x .eq. zero) goto 115 2539 do 11 k=1,n 2540 y(k) = y(k) - x*p(k,j) 2541 11 continue 2542 flops = flops + 2*n 2543 115 j = j-1 2544 ju = ju -1 2545 if (ju .ge. 1) goto 10 2546 12 indp = indp + 1 2547 if (indp .gt. lbp) indp = 1 2548 usav(indp) = u(np) 2549 do 13 k=1,n 2550 p(k,indp) = y(k) 2551 13 continue 2552 return 2553 !----------------------------------------------------------------------- 2554 !-------end-of-uppdir--------------------------------------------------- 2555 end Page 70 Source Listing UPPDIR 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name uppdir_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 2536 2545 11 Label 2541 2539 115 Label 2543 2538 12 Label 2546 2533 13 Label 2551 2549 FLOPS Dummy 2518 R(8) 8 scalar ARG,INOUT 2542 INDP Dummy 2518 I(4) 4 scalar ARG,INOUT 2534,2546,2547,2548,2550 J Local 2521 I(4) 4 scalar 2534,2536,2537,2540,2543 JU Local 2521 I(4) 4 scalar 2535,2537,2544,2545 K Local 2521 I(4) 4 scalar 2539,2540,2549,2550 LBP Dummy 2518 I(4) 4 scalar ARG,INOUT 2522,2536,2547 N Dummy 2518 I(4) 4 scalar ARG,INOUT 2522,2539,2542,2549 NP Dummy 2518 I(4) 4 scalar ARG,INOUT 2532,2533,2548 NPM1 Local 2521 I(4) 4 scalar 2532,2535 P Dummy 2518 R(8) 8 2 0 ARG,INOUT 2540,2550 U Dummy 2518 R(8) 8 1 0 ARG,INOUT 2537,2548 UPPDIR Subr 2518 USAV Dummy 2518 R(8) 8 1 0 ARG,INOUT 2537,2548 X Local 2522 R(8) 8 scalar 2537,2538,2540 Y Dummy 2518 R(8) 8 1 0 ARG,INOUT 2540,2550 ZERO Param 2529 R(8) 8 scalar 2538 Page 71 Source Listing UPPDIR 2014-09-16 16:49 w3profsmd.f90 2556 2557 subroutine givens(x,y,c,s) 2558 implicit none 2559 2560 real*8 :: x,y,c,s 2561 !----------------------------------------------------------------------- 2562 ! Given x and y, this subroutine generates a Givens' rotation c, s. 2563 ! And apply the rotation on (x,y) ==> (sqrt(x**2 + y**2), 0). 2564 ! (See P 202 of "matrix computation" by Golub and van Loan.) 2565 !----------------------------------------------------------------------- 2566 real*8 :: t,one,zero 2567 parameter (zero=0.0D0,one=1.0D0) 2568 ! 2569 if (x.eq.zero .and. y.eq.zero) then 2570 c = one 2571 s = zero 2572 else if (abs(y).gt.abs(x)) then 2573 t = x / y 2574 x = sqrt(one+t*t) 2575 s = sign(one / x, y) 2576 c = t*s 2577 else if (abs(y).le.abs(x)) then 2578 t = y / x 2579 y = sqrt(one+t*t) 2580 c = sign(one / y, x) 2581 s = t*c 2582 else 2583 ! 2584 ! X or Y must be an invalid floating-point number, set both to zero 2585 ! 2586 x = zero 2587 y = zero 2588 c = one 2589 s = zero 2590 endif 2591 x = abs(x*y) 2592 ! 2593 ! end of givens 2594 ! 2595 return 2596 end Page 72 Source Listing GIVENS 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name givens_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 2572 scalar 2572,2577,2591 C Dummy 2557 R(8) 8 scalar ARG,INOUT 2570,2576,2580,2581,2588 GIVENS Subr 2557 ONE Param 2566 R(8) 8 scalar 2570,2574,2575,2579,2580,2588 S Dummy 2557 R(8) 8 scalar ARG,INOUT 2571,2575,2576,2581,2589 SIGN Func 2575 scalar 2575,2580 SQRT Func 2574 scalar 2574,2579 T Local 2566 R(8) 8 scalar 2573,2574,2576,2578,2579,2581 X Dummy 2557 R(8) 8 scalar ARG,INOUT 2569,2572,2573,2574,2575,2577,2578 ,2580,2586,2591 Y Dummy 2557 R(8) 8 scalar ARG,INOUT 2569,2572,2573,2575,2577,2578,2579 ,2580,2587,2591 ZERO Param 2566 R(8) 8 scalar 2569,2571,2586,2587,2589 Page 73 Source Listing GIVENS 2014-09-16 16:49 w3profsmd.f90 2597 !-----end-of-givens 2598 !----------------------------------------------------------------------- 2599 logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) 2600 implicit none 2601 integer n,mvpi,ipar(16) 2602 real*8 fpar(16), r(n), delx(n), sx, ddot 2603 external ddot 2604 !----------------------------------------------------------------------- 2605 ! function for determining the stopping criteria. return value of 2606 ! true if the stopbis criteria is satisfied. 2607 !----------------------------------------------------------------------- 2608 if (ipar(11) .eq. 1) then 2609 stopbis = .true. 2610 else 2611 stopbis = .false. 2612 endif 2613 if (ipar(6).gt.0 .and. ipar(7).ge.ipar(6)) then 2614 ipar(1) = -1 2615 stopbis = .true. 2616 endif 2617 if (stopbis) return 2618 ! 2619 ! computes errors 2620 ! 2621 fpar(5) = sqrt(ddot(n,r,r)) 2622 fpar(11) = fpar(11) + 2 * n 2623 if (ipar(3).lt.0) then 2624 ! 2625 ! compute the change in the solution vector 2626 ! 2627 fpar(6) = sx * sqrt(ddot(n,delx,delx)) 2628 fpar(11) = fpar(11) + 2 * n 2629 if (ipar(7).lt.mvpi+mvpi+1) then 2630 ! 2631 ! if this is the end of the first iteration, set fpar(3:4) 2632 ! 2633 fpar(3) = fpar(6) 2634 if (ipar(3).eq.-1) then 2635 fpar(4) = fpar(1) * fpar(3) + fpar(2) 2636 endif 2637 endif 2638 else 2639 fpar(6) = fpar(5) 2640 endif 2641 ! 2642 ! .. the test is struct this way so that when the value in fpar(6) 2643 ! is not a valid number, STOPBIS is set to .true. 2644 ! 2645 if (fpar(6).gt.fpar(4)) then 2646 stopbis = .false. 2647 ipar(11) = 0 2648 else 2649 stopbis = .true. 2650 ipar(11) = 1 2651 endif 2652 ! 2653 return Page 74 Source Listing STOPBIS 2014-09-16 16:49 w3profsmd.f90 2654 end ENTRY POINTS Name stopbis_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DDOT Func 2602 R(8) 8 scalar 2621,2627 DELX Dummy 2599 R(8) 8 1 0 ARG,INOUT 2627 FPAR Dummy 2599 R(8) 8 1 16 ARG,INOUT 2621,2622,2627,2628,2633,2635,2639 ,2645 IPAR Dummy 2599 I(4) 4 1 16 ARG,INOUT 2608,2613,2614,2623,2629,2634,2647 ,2650 MVPI Dummy 2599 I(4) 4 scalar ARG,INOUT 2629 N Dummy 2599 I(4) 4 scalar ARG,INOUT 2602,2621,2622,2627,2628 R Dummy 2599 R(8) 8 1 0 ARG,INOUT 2621 SQRT Func 2621 scalar 2621,2627 STOPBIS Func 2599 L(4) 4 scalar 2609,2611,2615,2617,2646,2649 STOPBIS@0 Local 2599 L(4) 4 scalar SX Dummy 2599 R(8) 8 scalar ARG,INOUT 2627 Page 75 Source Listing STOPBIS 2014-09-16 16:49 w3profsmd.f90 2655 !-----end-of-stopbis 2656 !----------------------------------------------------------------------- 2657 subroutine tidycg(n,ipar,fpar,sol,delx) 2658 implicit none 2659 integer i,n,ipar(16) 2660 real*8 fpar(16),sol(n),delx(n) 2661 !----------------------------------------------------------------------- 2662 ! Some common operations required before terminating the CG routines 2663 !----------------------------------------------------------------------- 2664 real*8 zero 2665 parameter(zero=0.0D0) 2666 ! 2667 if (ipar(12).ne.0) then 2668 ipar(1) = ipar(12) 2669 else if (ipar(1).gt.0) then 2670 if ((ipar(3).eq.999 .and. ipar(11).eq.1) .or. & 2671 & fpar(6).le.fpar(4)) then 2672 ipar(1) = 0 2673 else if (ipar(7).ge.ipar(6) .and. ipar(6).gt.0) then 2674 ipar(1) = -1 2675 else 2676 ipar(1) = -10 2677 endif 2678 endif 2679 if (fpar(3).gt.zero .and. fpar(6).gt.zero .and. ipar(7).gt.ipar(13)) then 2680 fpar(7) = log10(fpar(3) / fpar(6)) / dble(ipar(7)-ipar(13)) 2681 else 2682 fpar(7) = zero 2683 endif 2684 do i = 1, n 2685 sol(i) = sol(i) + delx(i) 2686 enddo 2687 return 2688 end Page 76 Source Listing TIDYCG 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name tidycg_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References DBLE Func 2680 scalar 2680 DELX Dummy 2657 R(8) 8 1 0 ARG,INOUT 2685 FPAR Dummy 2657 R(8) 8 1 16 ARG,INOUT 2671,2679,2680,2682 I Local 2659 I(4) 4 scalar 2684,2685 IPAR Dummy 2657 I(4) 4 1 16 ARG,INOUT 2667,2668,2669,2670,2672,2673,2674 ,2676,2679,2680 LOG10 Func 2680 scalar 2680 N Dummy 2657 I(4) 4 scalar ARG,INOUT 2660,2684 SOL Dummy 2657 R(8) 8 1 0 ARG,INOUT 2685 TIDYCG Subr 2657 ZERO Param 2664 R(8) 8 scalar 2679,2682 Page 77 Source Listing TIDYCG 2014-09-16 16:49 w3profsmd.f90 2689 !-----end-of-tidycg 2690 !----------------------------------------------------------------------- 2691 logical function brkdn(alpha, ipar) 2692 implicit none 2693 integer ipar(16) 2694 real*8 alpha, beta, zero, one 2695 parameter (zero=0.0D0, one=1.0D0) 2696 !----------------------------------------------------------------------- 2697 ! test whether alpha is zero or an abnormal number, if yes, 2698 ! this routine will return .true. 2699 ! 2700 ! If alpha == 0, ipar(1) = -3, 2701 ! if alpha is an abnormal number, ipar(1) = -9. 2702 !----------------------------------------------------------------------- 2703 brkdn = .false. 2704 if (alpha.gt.zero) then 2705 beta = one / alpha 2706 if (.not. beta.gt.zero) then 2707 brkdn = .true. 2708 ipar(1) = -9 2709 endif 2710 else if (alpha.lt.zero) then 2711 beta = one / alpha 2712 if (.not. beta.lt.zero) then 2713 brkdn = .true. 2714 ipar(1) = -9 2715 endif 2716 else if (alpha.eq.zero) then 2717 brkdn = .true. 2718 ipar(1) = -3 2719 else 2720 brkdn = .true. 2721 ipar(1) = -9 2722 endif 2723 return 2724 end Page 78 Source Listing BRKDN 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name brkdn_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ALPHA Dummy 2691 R(8) 8 scalar ARG,INOUT 2704,2705,2710,2711,2716 BETA Local 2694 R(8) 8 scalar 2705,2706,2711,2712 BRKDN Func 2691 L(4) 4 scalar 2703,2707,2713,2717,2720 BRKDN@0 Local 2691 L(4) 4 scalar IPAR Dummy 2691 I(4) 4 1 16 ARG,INOUT 2708,2714,2718,2721 ONE Param 2694 R(8) 8 scalar 2705,2711 ZERO Param 2694 R(8) 8 scalar 2704,2706,2710,2712,2716 Page 79 Source Listing BRKDN 2014-09-16 16:49 w3profsmd.f90 2725 !-----end-of-brkdn 2726 !----------------------------------------------------------------------- 2727 subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) 2728 implicit none 2729 integer i,ipar(16),wksize,dsc 2730 logical lp,rp 2731 real*8 fpar(16),wk(*) 2732 !----------------------------------------------------------------------- 2733 ! some common initializations for the iterative solvers 2734 !----------------------------------------------------------------------- 2735 real*8 zero, one 2736 parameter(zero=0.0D0, one=1.0D0) 2737 ! 2738 ! ipar(1) = -2 inidcate that there are not enough space in the work 2739 ! array 2740 ! 2741 if (ipar(4).lt.wksize) then 2742 ipar(1) = -2 2743 ipar(4) = wksize 2744 return 2745 endif 2746 ! 2747 if (ipar(2).gt.2) then 2748 lp = .true. 2749 rp = .true. 2750 else if (ipar(2).eq.2) then 2751 lp = .false. 2752 rp = .true. 2753 else if (ipar(2).eq.1) then 2754 lp = .true. 2755 rp = .false. 2756 else 2757 lp = .false. 2758 rp = .false. 2759 endif 2760 if (ipar(3).eq.0) ipar(3) = dsc 2761 ! .. clear the ipar elements used 2762 ipar(7) = 0 2763 ipar(8) = 0 2764 ipar(9) = 0 2765 ipar(10) = 0 2766 ipar(11) = 0 2767 ipar(12) = 0 2768 ipar(13) = 0 2769 ! 2770 ! fpar(1) must be between (0, 1), fpar(2) must be positive, 2771 ! fpar(1) and fpar(2) can NOT both be zero 2772 ! Normally return ipar(1) = -4 to indicate any of above error 2773 ! 2774 if (fpar(1).lt.zero .or. fpar(1).ge.one .or. fpar(2).lt.zero .or. & 2775 & (fpar(1).eq.zero .and. fpar(2).eq.zero)) then 2776 if (ipar(1).eq.0) then 2777 ipar(1) = -4 2778 return 2779 else 2780 fpar(1) = 1.0D-6 2781 fpar(2) = 1.0D-16 Page 80 Source Listing BISINIT 2014-09-16 16:49 w3profsmd.f90 2782 endif 2783 endif 2784 ! .. clear the fpar elements 2785 do i = 3, 10 2786 fpar(i) = zero 2787 enddo 2788 if (fpar(11).lt.zero) fpar(11) = zero 2789 ! .. clear the used portion of the work array to zero 2790 do i = 1, wksize 2791 wk(i) = zero 2792 enddo 2793 ! 2794 return 2795 !-----end-of-bisinit 2796 end ENTRY POINTS Name bisinit_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References BISINIT Subr 2727 DSC Dummy 2727 I(4) 4 scalar ARG,INOUT 2760 FPAR Dummy 2727 R(8) 8 1 16 ARG,INOUT 2774,2775,2780,2781,2786,2788 I Local 2729 I(4) 4 scalar 2785,2786,2790,2791 IPAR Dummy 2727 I(4) 4 1 16 ARG,INOUT 2741,2742,2743,2747,2750,2753,2760 ,2762,2763,2764,2765,2766,2767,276 8,2776,2777 LP Dummy 2727 L(4) 4 scalar ARG,INOUT 2748,2751,2754,2757 ONE Param 2735 R(8) 8 scalar 2774 RP Dummy 2727 L(4) 4 scalar ARG,INOUT 2749,2752,2755,2758 WK Dummy 2727 R(8) 8 1 0 ARG,INOUT 2791 WKSIZE Dummy 2727 I(4) 4 scalar ARG,INOUT 2741,2743,2790 ZERO Param 2735 R(8) 8 scalar 2774,2775,2786,2788,2791 Page 81 Source Listing BISINIT 2014-09-16 16:49 w3profsmd.f90 2797 !----------------------------------------------------------------------- 2798 subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) 2799 implicit none 2800 logical full 2801 integer lda,m,n,ind,ierr 2802 real*8 ops,hh(m),vec(lda,m) 2803 !----------------------------------------------------------------------- 2804 ! MGSRO -- Modified Gram-Schmidt procedure with Selective Re- 2805 ! Orthogonalization 2806 ! The ind'th vector of VEC is orthogonalized against the rest of 2807 ! the vectors. 2808 ! 2809 ! The test for performing re-orthogonalization is performed for 2810 ! each indivadual vectors. If the cosine between the two vectors 2811 ! is greater than 0.99 (REORTH = 0.99**2), re-orthogonalization is 2812 ! performed. The norm of the 'new' vector is kept in variable NRM0, 2813 ! and updated after operating with each vector. 2814 ! 2815 ! full -- .ture. if it is necessary to orthogonalize the ind'th 2816 ! against all the vectors vec(:,1:ind-1), vec(:,ind+2:m) 2817 ! .false. only orthogonalize againt vec(:,1:ind-1) 2818 ! lda -- the leading dimension of VEC 2819 ! n -- length of the vector in VEC 2820 ! m -- number of vectors can be stored in VEC 2821 ! ind -- index to the vector to be changed 2822 ! ops -- operation counts 2823 ! vec -- vector of LDA X M storing the vectors 2824 ! hh -- coefficient of the orthogonalization 2825 ! ierr -- error code 2826 ! 0 : successful return 2827 ! -1: zero input vector 2828 ! -2: input vector contains abnormal numbers 2829 ! -3: input vector is a linear combination of others 2830 ! 2831 ! External routines used: real*8 ddot 2832 !----------------------------------------------------------------------- 2833 integer i,k 2834 real*8 nrm0, nrm1, fct, thr, ddot, zero, one, reorth 2835 parameter (zero=0.0D0, one=1.0D0, reorth=0.98D0) 2836 external ddot 2837 ! 2838 ! compute the norm of the input vector 2839 ! 2840 nrm0 = ddot(n,vec(1,ind),vec(1,ind)) 2841 ops = ops + n + n 2842 thr = nrm0 * reorth 2843 if (nrm0.le.zero) then 2844 ierr = - 1 2845 return 2846 else if (nrm0.gt.zero .and. one/nrm0.gt.zero) then 2847 ierr = 0 2848 else 2849 ierr = -2 2850 return 2851 endif 2852 ! 2853 ! Modified Gram-Schmidt loop Page 82 Source Listing MGSRO 2014-09-16 16:49 w3profsmd.f90 2854 ! 2855 if (full) then 2856 do 40 i = ind+1, m 2857 fct = ddot(n,vec(1,ind),vec(1,i)) 2858 hh(i) = fct 2859 do 20 k = 1, n 2860 vec(k,ind) = vec(k,ind) - fct * vec(k,i) 2861 20 continue 2862 ops = ops + 4 * n + 2 2863 if (fct*fct.gt.thr) then 2864 fct = ddot(n,vec(1,ind),vec(1,i)) 2865 hh(i) = hh(i) + fct 2866 do 30 k = 1, n 2867 vec(k,ind) = vec(k,ind) - fct * vec(k,i) 2868 30 continue 2869 ops = ops + 4*n + 1 2870 endif 2871 nrm0 = nrm0 - hh(i) * hh(i) 2872 if (nrm0.lt.zero) nrm0 = zero 2873 thr = nrm0 * reorth 2874 40 continue 2875 endif 2876 ! 2877 do 70 i = 1, ind-1 2878 fct = ddot(n,vec(1,ind),vec(1,i)) 2879 hh(i) = fct 2880 do 50 k = 1, n 2881 vec(k,ind) = vec(k,ind) - fct * vec(k,i) 2882 50 continue 2883 ops = ops + 4 * n + 2 2884 if (fct*fct.gt.thr) then 2885 fct = ddot(n,vec(1,ind),vec(1,i)) 2886 hh(i) = hh(i) + fct 2887 do 60 k = 1, n 2888 vec(k,ind) = vec(k,ind) - fct * vec(k,i) 2889 60 continue 2890 ops = ops + 4*n + 1 2891 endif 2892 nrm0 = nrm0 - hh(i) * hh(i) 2893 if (nrm0.lt.zero) nrm0 = zero 2894 thr = nrm0 * reorth 2895 70 continue 2896 ! 2897 ! test the resulting vector 2898 ! 2899 nrm1 = sqrt(ddot(n,vec(1,ind),vec(1,ind))) 2900 ops = ops + n + n 2901 hh(ind) = nrm1 ! statement label 75 2902 if (nrm1.le.zero) then 2903 ierr = -3 2904 return 2905 endif 2906 ! 2907 ! scale the resulting vector 2908 ! 2909 fct = one / nrm1 2910 do 80 k = 1, n Page 83 Source Listing MGSRO 2014-09-16 16:49 w3profsmd.f90 2911 vec(k,ind) = vec(k,ind) * fct 2912 80 continue 2913 ops = ops + n + 1 2914 ! 2915 ! normal return 2916 ! 2917 ierr = 0 2918 return 2919 ! end surbotine mgsro 2920 end ENTRY POINTS Name mgsro_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 20 Label 2861 2859 30 Label 2868 2866 40 Label 2874 2856 50 Label 2882 2880 60 Label 2889 2887 70 Label 2895 2877 80 Label 2912 2910 DDOT Func 2834 R(8) 8 scalar 2840,2857,2864,2878,2885,2899 FCT Local 2834 R(8) 8 scalar 2857,2858,2860,2863,2864,2865,2867 ,2878,2879,2881,2884,2885,2886,288 8,2909,2911 FULL Dummy 2798 L(4) 4 scalar ARG,INOUT 2855 HH Dummy 2798 R(8) 8 1 0 ARG,INOUT 2858,2865,2871,2879,2886,2892,2901 I Local 2833 I(4) 4 scalar 2856,2857,2858,2860,2864,2865,2867 ,2871,2877,2878,2879,2881,2885,288 6,2888,2892 IERR Dummy 2798 I(4) 4 scalar ARG,INOUT 2844,2847,2849,2903,2917 IND Dummy 2798 I(4) 4 scalar ARG,INOUT 2840,2856,2857,2860,2864,2867,2877 ,2878,2881,2885,2888,2899,2901,291 1 K Local 2833 I(4) 4 scalar 2859,2860,2866,2867,2880,2881,2887 ,2888,2910,2911 LDA Dummy 2798 I(4) 4 scalar ARG,INOUT 2802 M Dummy 2798 I(4) 4 scalar ARG,INOUT 2802,2856 MGSRO Subr 2798 N Dummy 2798 I(4) 4 scalar ARG,INOUT 2840,2841,2857,2859,2862,2864,2866 ,2869,2878,2880,2883,2885,2887,289 0,2899,2900,2910,2913 NRM0 Local 2834 R(8) 8 scalar 2840,2842,2843,2846,2871,2872,2873 ,2892,2893,2894 NRM1 Local 2834 R(8) 8 scalar 2899,2901,2902,2909 ONE Param 2834 R(8) 8 scalar 2846,2909 OPS Dummy 2798 R(8) 8 scalar ARG,INOUT 2841,2862,2869,2883,2890,2900,2913 REORTH Param 2834 R(8) 8 scalar 2842,2873,2894 Page 84 Source Listing MGSRO 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References SQRT Func 2899 scalar 2899 THR Local 2834 R(8) 8 scalar 2842,2863,2873,2884,2894 VEC Dummy 2798 R(8) 8 2 0 ARG,INOUT 2840,2857,2860,2864,2867,2878,2881 ,2885,2888,2899,2911 ZERO Param 2834 R(8) 8 scalar 2843,2846,2872,2893,2902 Page 85 Source Listing MGSRO 2014-09-16 16:49 w3profsmd.f90 2921 !----------------------------------------------------------------------c 2922 ! S P A R S K I T c 2923 !----------------------------------------------------------------------c 2924 ! BASIC MATRIX-VECTOR OPERATIONS - MATVEC MODULE c 2925 ! Matrix-vector Mulitiplications and Triang. Solves c 2926 !----------------------------------------------------------------------c 2927 ! contents: (as of Nov 18, 1991) c 2928 !---------- c 2929 ! 1) Matrix-vector products: c 2930 !--------------------------- c 2931 ! amux : A times a vector. Compressed Sparse Row (CSR) format. c 2932 ! amuxms: A times a vector. Modified Compress Sparse Row format. c 2933 ! atmux : Transp(A) times a vector. CSR format. c 2934 ! atmuxr: Transp(A) times a vector. CSR format. A rectangular. c 2935 ! amuxe : A times a vector. Ellpack/Itpack (ELL) format. c 2936 ! amuxd : A times a vector. Diagonal (DIA) format. c 2937 ! amuxj : A times a vector. Jagged Diagonal (JAD) format. c 2938 ! vbrmv : Sparse matrix-full vector product, in VBR format c 2939 ! c 2940 ! 2) Triangular system solutions: c 2941 !------------------------------- c 2942 ! lsol : Unit Lower Triang. solve. Compressed Sparse Row (CSR) format.c 2943 ! ldsol : Lower Triang. solve. Modified Sparse Row (MSR) format. c 2944 ! lsolc : Unit Lower Triang. solve. Comp. Sparse Column (CSC) format. c 2945 ! ldsolc: Lower Triang. solve. Modified Sparse Column (MSC) format. c 2946 ! ldsoll: Lower Triang. solve with level scheduling. MSR format. c 2947 ! usol : Unit Upper Triang. solve. Compressed Sparse Row (CSR) format.c 2948 ! udsol : Upper Triang. solve. Modified Sparse Row (MSR) format. c 2949 ! usolc : Unit Upper Triang. solve. Comp. Sparse Column (CSC) format. c 2950 ! udsolc: Upper Triang. solve. Modified Sparse Column (MSC) format. c 2951 !----------------------------------------------------------------------c 2952 ! 1) M A T R I X B Y V E C T O R P R O D U C T S c 2953 !----------------------------------------------------------------------c 2954 subroutine amux (n, x, y, a,ja,ia) 2955 real*8 x(*), y(*), a(*) 2956 integer n, ja(*), ia(*) 2957 !----------------------------------------------------------------------- 2958 ! A times a vector 2959 !----------------------------------------------------------------------- 2960 ! multiplies a matrix by a vector using the dot product form 2961 ! Matrix A is stored in compressed sparse row storage. 2962 ! 2963 ! on entry: 2964 !---------- 2965 ! n = row dimension of A 2966 ! x = real array of length equal to the column dimension of 2967 ! the A matrix. 2968 ! a, ja, 2969 ! ia = input matrix in compressed sparse row format. 2970 ! 2971 ! on return: 2972 !----------- 2973 ! y = real array of length n, containing the product y=Ax 2974 ! 2975 !----------------------------------------------------------------------- 2976 ! local variables 2977 ! Page 86 Source Listing AMUX 2014-09-16 16:49 w3profsmd.f90 2978 real*8 t 2979 integer i, k 2980 !----------------------------------------------------------------------- 2981 do 100 i = 1,n 2982 ! 2983 ! compute the inner product of row i with vector x 2984 ! 2985 t = 0.0d0 2986 do 99 k=ia(i), ia(i+1)-1 2987 t = t + a(k)*x(ja(k)) 2988 99 continue 2989 ! 2990 ! store result in y(i) 2991 ! 2992 y(i) = t 2993 100 continue 2994 ! 2995 return 2996 !---------end-of-amux--------------------------------------------------- 2997 !----------------------------------------------------------------------- 2998 end ENTRY POINTS Name amux_ Page 87 Source Listing AMUX 2014-09-16 16:49 Symbol Table w3profsmd.f90 SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 2993 2981 99 Label 2988 2986 A Dummy 2954 R(8) 8 1 0 ARG,INOUT 2987 AMUX Subr 2954 I Local 2979 I(4) 4 scalar 2981,2986,2992 IA Dummy 2954 I(4) 4 1 0 ARG,INOUT 2986 JA Dummy 2954 I(4) 4 1 0 ARG,INOUT 2987 K Local 2979 I(4) 4 scalar 2986,2987 N Dummy 2954 I(4) 4 scalar ARG,INOUT 2981 T Local 2978 R(8) 8 scalar 2985,2987,2992 X Dummy 2954 R(8) 8 1 0 ARG,INOUT 2987 Y Dummy 2954 R(8) 8 1 0 ARG,INOUT 2992 Page 88 Source Listing AMUX 2014-09-16 16:49 w3profsmd.f90 2999 !----------------------------------------------------------------------- 3000 subroutine amuxms (n, x, y, a,ja) 3001 real*8 x(*), y(*), a(*) 3002 integer n, ja(*) 3003 !----------------------------------------------------------------------- 3004 ! A times a vector in MSR format 3005 !----------------------------------------------------------------------- 3006 ! multiplies a matrix by a vector using the dot product form 3007 ! Matrix A is stored in Modified Sparse Row storage. 3008 ! 3009 ! on entry: 3010 !---------- 3011 ! n = row dimension of A 3012 ! x = real array of length equal to the column dimension of 3013 ! the A matrix. 3014 ! a, ja,= input matrix in modified compressed sparse row format. 3015 ! 3016 ! on return: 3017 !----------- 3018 ! y = real array of length n, containing the product y=Ax 3019 ! 3020 !----------------------------------------------------------------------- 3021 ! local variables 3022 ! 3023 integer i, k 3024 !----------------------------------------------------------------------- 3025 do 10 i=1, n 3026 y(i) = a(i)*x(i) 3027 10 continue 3028 do 100 i = 1,n 3029 ! 3030 ! compute the inner product of row i with vector x 3031 ! 3032 do 99 k=ja(i), ja(i+1)-1 3033 y(i) = y(i) + a(k) *x(ja(k)) 3034 99 continue 3035 100 continue 3036 ! 3037 return 3038 !---------end-of-amuxm-------------------------------------------------- 3039 !----------------------------------------------------------------------- 3040 end Page 89 Source Listing AMUXMS 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name amuxms_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 3027 3025 100 Label 3035 3028 99 Label 3034 3032 A Dummy 3000 R(8) 8 1 0 ARG,INOUT 3026,3033 AMUXMS Subr 3000 I Local 3023 I(4) 4 scalar 3025,3026,3028,3032,3033 JA Dummy 3000 I(4) 4 1 0 ARG,INOUT 3032,3033 K Local 3023 I(4) 4 scalar 3032,3033 N Dummy 3000 I(4) 4 scalar ARG,INOUT 3025,3028 X Dummy 3000 R(8) 8 1 0 ARG,INOUT 3026,3033 Y Dummy 3000 R(8) 8 1 0 ARG,INOUT 3026,3033 Page 90 Source Listing AMUXMS 2014-09-16 16:49 w3profsmd.f90 3041 !----------------------------------------------------------------------- 3042 subroutine atmux (n, x, y, a, ja, ia) 3043 real*8 x(*), y(*), a(*) 3044 integer n, ia(*), ja(*) 3045 !----------------------------------------------------------------------- 3046 ! transp( A ) times a vector 3047 !----------------------------------------------------------------------- 3048 ! multiplies the transpose of a matrix by a vector when the original 3049 ! matrix is stored in compressed sparse row storage. Can also be 3050 ! viewed as the product of a matrix by a vector when the original 3051 ! matrix is stored in the compressed sparse column format. 3052 !----------------------------------------------------------------------- 3053 ! 3054 ! on entry: 3055 !---------- 3056 ! n = row dimension of A 3057 ! x = real array of length equal to the column dimension of 3058 ! the A matrix. 3059 ! a, ja, 3060 ! ia = input matrix in compressed sparse row format. 3061 ! 3062 ! on return: 3063 !----------- 3064 ! y = real array of length n, containing the product y=transp(A)*x 3065 ! 3066 !----------------------------------------------------------------------- 3067 ! local variables 3068 ! 3069 integer i, k 3070 !----------------------------------------------------------------------- 3071 ! 3072 ! zero out output vector 3073 ! 3074 do 1 i=1,n 3075 y(i) = 0.0 3076 1 continue 3077 ! 3078 ! loop over the rows 3079 ! 3080 do 100 i = 1,n 3081 do 99 k=ia(i), ia(i+1)-1 3082 y(ja(k)) = y(ja(k)) + x(i)*a(k) 3083 99 continue 3084 100 continue 3085 ! 3086 return 3087 !-------------end-of-atmux---------------------------------------------- 3088 !----------------------------------------------------------------------- 3089 end Page 91 Source Listing ATMUX 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name atmux_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3076 3074 100 Label 3084 3080 99 Label 3083 3081 A Dummy 3042 R(8) 8 1 0 ARG,INOUT 3082 ATMUX Subr 3042 I Local 3069 I(4) 4 scalar 3074,3075,3080,3081,3082 IA Dummy 3042 I(4) 4 1 0 ARG,INOUT 3081 JA Dummy 3042 I(4) 4 1 0 ARG,INOUT 3082 K Local 3069 I(4) 4 scalar 3081,3082 N Dummy 3042 I(4) 4 scalar ARG,INOUT 3074,3080 X Dummy 3042 R(8) 8 1 0 ARG,INOUT 3082 Y Dummy 3042 R(8) 8 1 0 ARG,INOUT 3075,3082 Page 92 Source Listing ATMUX 2014-09-16 16:49 w3profsmd.f90 3090 !----------------------------------------------------------------------- 3091 subroutine atmuxr (m, n, x, y, a, ja, ia) 3092 real*8 x(*), y(*), a(*) 3093 integer m, n, ia(*), ja(*) 3094 !----------------------------------------------------------------------- 3095 ! transp( A ) times a vector, A can be rectangular 3096 !----------------------------------------------------------------------- 3097 ! See also atmux. The essential difference is how the solution vector 3098 ! is initially zeroed. If using this to multiply rectangular CSC 3099 ! matrices by a vector, m number of rows, n is number of columns. 3100 !----------------------------------------------------------------------- 3101 ! 3102 ! on entry: 3103 !---------- 3104 ! m = column dimension of A 3105 ! n = row dimension of A 3106 ! x = real array of length equal to the column dimension of 3107 ! the A matrix. 3108 ! a, ja, 3109 ! ia = input matrix in compressed sparse row format. 3110 ! 3111 ! on return: 3112 !----------- 3113 ! y = real array of length n, containing the product y=transp(A)*x 3114 ! 3115 !----------------------------------------------------------------------- 3116 ! local variables 3117 ! 3118 integer i, k 3119 !----------------------------------------------------------------------- 3120 ! 3121 ! zero out output vector 3122 ! 3123 do 1 i=1,m 3124 y(i) = 0.0 3125 1 continue 3126 ! 3127 ! loop over the rows 3128 ! 3129 do 100 i = 1,n 3130 do 99 k=ia(i), ia(i+1)-1 3131 y(ja(k)) = y(ja(k)) + x(i)*a(k) 3132 99 continue 3133 100 continue 3134 ! 3135 return 3136 !-------------end-of-atmuxr--------------------------------------------- 3137 !----------------------------------------------------------------------- 3138 end Page 93 Source Listing ATMUXR 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name atmuxr_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3125 3123 100 Label 3133 3129 99 Label 3132 3130 A Dummy 3091 R(8) 8 1 0 ARG,INOUT 3131 ATMUXR Subr 3091 I Local 3118 I(4) 4 scalar 3123,3124,3129,3130,3131 IA Dummy 3091 I(4) 4 1 0 ARG,INOUT 3130 JA Dummy 3091 I(4) 4 1 0 ARG,INOUT 3131 K Local 3118 I(4) 4 scalar 3130,3131 M Dummy 3091 I(4) 4 scalar ARG,INOUT 3123 N Dummy 3091 I(4) 4 scalar ARG,INOUT 3129 X Dummy 3091 R(8) 8 1 0 ARG,INOUT 3131 Y Dummy 3091 R(8) 8 1 0 ARG,INOUT 3124,3131 Page 94 Source Listing ATMUXR 2014-09-16 16:49 w3profsmd.f90 3139 !----------------------------------------------------------------------- 3140 subroutine amuxe (n,x,y,na,ncol,a,ja) 3141 implicit none 3142 3143 integer :: n, na, ncol, ja(na,*) 3144 real*8 :: x(n), y(n), a(na,*) 3145 3146 !----------------------------------------------------------------------- 3147 ! A times a vector in Ellpack Itpack format (ELL) 3148 !----------------------------------------------------------------------- 3149 ! multiplies a matrix by a vector when the original matrix is stored 3150 ! in the ellpack-itpack sparse format. 3151 !----------------------------------------------------------------------- 3152 ! 3153 ! on entry: 3154 !---------- 3155 ! n = row dimension of A 3156 ! x = real array of length equal to the column dimension of 3157 ! the A matrix. 3158 ! na = integer. The first dimension of arrays a and ja 3159 ! as declared by the calling program. 3160 ! ncol = integer. The number of active columns in array a. 3161 ! (i.e., the number of generalized diagonals in matrix.) 3162 ! a, ja = the real and integer arrays of the itpack format 3163 ! (a(i,k),k=1,ncol contains the elements of row i in matrix 3164 ! ja(i,k),k=1,ncol contains their column numbers) 3165 ! 3166 ! on return: 3167 !----------- 3168 ! y = real array of length n, containing the product y=y=A*x 3169 ! 3170 !----------------------------------------------------------------------- 3171 ! local variables 3172 ! 3173 integer i, j 3174 !----------------------------------------------------------------------- 3175 do 1 i=1, n 3176 y(i) = 0.0 3177 1 continue 3178 do 10 j=1,ncol 3179 do 25 i = 1,n 3180 y(i) = y(i)+a(i,j)*x(ja(i,j)) 3181 25 continue 3182 10 continue 3183 ! 3184 return 3185 !--------end-of-amuxe--------------------------------------------------- 3186 !----------------------------------------------------------------------- 3187 end Page 95 Source Listing AMUXE 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name amuxe_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3177 3175 10 Label 3182 3178 25 Label 3181 3179 A Dummy 3140 R(8) 8 2 0 ARG,INOUT 3180 AMUXE Subr 3140 I Local 3173 I(4) 4 scalar 3175,3176,3179,3180 J Local 3173 I(4) 4 scalar 3178,3180 JA Dummy 3140 I(4) 4 2 0 ARG,INOUT 3180 N Dummy 3140 I(4) 4 scalar ARG,INOUT 3144,3175,3179 NA Dummy 3140 I(4) 4 scalar ARG,INOUT 3143,3144 NCOL Dummy 3140 I(4) 4 scalar ARG,INOUT 3178 X Dummy 3140 R(8) 8 1 0 ARG,INOUT 3180 Y Dummy 3140 R(8) 8 1 0 ARG,INOUT 3176,3180 Page 96 Source Listing AMUXE 2014-09-16 16:49 w3profsmd.f90 3188 !----------------------------------------------------------------------- 3189 subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff) 3190 integer n, ndiag, idiag, ioff(idiag) 3191 real*8 x(n), y(n), diag(ndiag,idiag) 3192 !----------------------------------------------------------------------- 3193 ! A times a vector in Diagonal storage format (DIA) 3194 !----------------------------------------------------------------------- 3195 ! multiplies a matrix by a vector when the original matrix is stored 3196 ! in the diagonal storage format. 3197 !----------------------------------------------------------------------- 3198 ! 3199 ! on entry: 3200 !---------- 3201 ! n = row dimension of A 3202 ! x = real array of length equal to the column dimension of 3203 ! the A matrix. 3204 ! ndiag = integer. The first dimension of array adiag as declared in 3205 ! the calling program. 3206 ! idiag = integer. The number of diagonals in the matrix. 3207 ! diag = real array containing the diagonals stored of A. 3208 ! idiag = number of diagonals in matrix. 3209 ! diag = real array of size (ndiag x idiag) containing the diagonals 3210 ! 3211 ! ioff = integer array of length idiag, containing the offsets of the 3212 ! diagonals of the matrix: 3213 ! diag(i,k) contains the element a(i,i+ioff(k)) of the matrix. 3214 ! 3215 ! on return: 3216 !----------- 3217 ! y = real array of length n, containing the product y=A*x 3218 ! 3219 !----------------------------------------------------------------------- 3220 ! local variables 3221 ! 3222 integer j, k, io, i1, i2 3223 !----------------------------------------------------------------------- 3224 do 1 j=1, n 3225 y(j) = 0.0d0 3226 1 continue 3227 do 10 j=1, idiag 3228 io = ioff(j) 3229 i1 = max0(1,1-io) 3230 i2 = min0(n,n-io) 3231 do 9 k=i1, i2 3232 y(k) = y(k)+diag(k,j)*x(k+io) 3233 9 continue 3234 10 continue 3235 ! 3236 return 3237 !----------end-of-amuxd------------------------------------------------- 3238 !----------------------------------------------------------------------- 3239 end Page 97 Source Listing AMUXD 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name amuxd_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3226 3224 10 Label 3234 3227 9 Label 3233 3231 AMUXD Subr 3189 DIAG Dummy 3189 R(8) 8 2 0 ARG,INOUT 3232 I1 Local 3222 I(4) 4 scalar 3229,3231 I2 Local 3222 I(4) 4 scalar 3230,3231 IDIAG Dummy 3189 I(4) 4 scalar ARG,INOUT 3190,3191,3227 IO Local 3222 I(4) 4 scalar 3228,3229,3230,3232 IOFF Dummy 3189 I(4) 4 1 0 ARG,INOUT 3228 J Local 3222 I(4) 4 scalar 3224,3225,3227,3228,3232 K Local 3222 I(4) 4 scalar 3231,3232 MAX0 Func 3229 scalar 3229 MIN0 Func 3230 scalar 3230 N Dummy 3189 I(4) 4 scalar ARG,INOUT 3191,3224,3230 NDIAG Dummy 3189 I(4) 4 scalar ARG,INOUT 3191 X Dummy 3189 R(8) 8 1 0 ARG,INOUT 3232 Y Dummy 3189 R(8) 8 1 0 ARG,INOUT 3225,3232 Page 98 Source Listing AMUXD 2014-09-16 16:49 w3profsmd.f90 3240 !----------------------------------------------------------------------- 3241 subroutine amuxj (n, x, y, jdiag, a, ja, ia) 3242 integer n, jdiag, ja(*), ia(*) 3243 real*8 x(n), y(n), a(*) 3244 !----------------------------------------------------------------------- 3245 ! A times a vector in Jagged-Diagonal storage format (JAD) 3246 !----------------------------------------------------------------------- 3247 ! multiplies a matrix by a vector when the original matrix is stored 3248 ! in the jagged diagonal storage format. 3249 !----------------------------------------------------------------------- 3250 ! 3251 ! on entry: 3252 !---------- 3253 ! n = row dimension of A 3254 ! x = real array of length equal to the column dimension of 3255 ! the A matrix. 3256 ! jdiag = integer. The number of jadded-diagonals in the data-structure. 3257 ! a = real array containing the jadded diagonals of A stored 3258 ! in succession (in decreasing lengths) 3259 ! j = integer array containing the colum indices of the 3260 ! corresponding elements in a. 3261 ! ia = integer array containing the lengths of the jagged diagonals 3262 ! 3263 ! on return: 3264 !----------- 3265 ! y = real array of length n, containing the product y=A*x 3266 ! 3267 ! Note: 3268 !------- 3269 ! Permutation related to the JAD format is not performed. 3270 ! this can be done by: 3271 ! call permvec (n,y,y,iperm) 3272 ! after the call to amuxj, where iperm is the permutation produced 3273 ! by csrjad. 3274 !----------------------------------------------------------------------- 3275 ! local variables 3276 ! 3277 integer i, ii, k1, ilen, j 3278 !----------------------------------------------------------------------- 3279 do 1 i=1, n 3280 y(i) = 0.0d0 3281 1 continue 3282 do 70 ii=1, jdiag 3283 k1 = ia(ii)-1 3284 ilen = ia(ii+1)-k1-1 3285 do 60 j=1,ilen 3286 y(j)= y(j)+a(k1+j)*x(ja(k1+j)) 3287 60 continue 3288 70 continue 3289 ! 3290 return 3291 !----------end-of-amuxj------------------------------------------------- 3292 !----------------------------------------------------------------------- 3293 end Page 99 Source Listing AMUXJ 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name amuxj_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3281 3279 60 Label 3287 3285 70 Label 3288 3282 A Dummy 3241 R(8) 8 1 0 ARG,INOUT 3286 AMUXJ Subr 3241 I Local 3277 I(4) 4 scalar 3279,3280 IA Dummy 3241 I(4) 4 1 0 ARG,INOUT 3283,3284 II Local 3277 I(4) 4 scalar 3282,3283,3284 ILEN Local 3277 I(4) 4 scalar 3284,3285 J Local 3277 I(4) 4 scalar 3285,3286 JA Dummy 3241 I(4) 4 1 0 ARG,INOUT 3286 JDIAG Dummy 3241 I(4) 4 scalar ARG,INOUT 3282 K1 Local 3277 I(4) 4 scalar 3283,3284,3286 N Dummy 3241 I(4) 4 scalar ARG,INOUT 3243,3279 X Dummy 3241 R(8) 8 1 0 ARG,INOUT 3286 Y Dummy 3241 R(8) 8 1 0 ARG,INOUT 3280,3286 Page 100 Source Listing AMUXJ 2014-09-16 16:49 w3profsmd.f90 3294 !----------------------------------------------------------------------- 3295 subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b) 3296 !----------------------------------------------------------------------- 3297 integer nr, nc, ia(nr+1), ja(*), ka(*), kvstr(nr+1), kvstc(*) 3298 real*8 a(*), x(*), b(*) 3299 !----------------------------------------------------------------------- 3300 ! Sparse matrix-full vector product, in VBR format. 3301 !----------------------------------------------------------------------- 3302 ! On entry: 3303 !-------------- 3304 ! nr, nc = number of block rows and columns in matrix A 3305 ! ia,ja,ka,a,kvstr,kvstc = matrix A in variable block row format 3306 ! x = multiplier vector in full format 3307 ! 3308 ! On return: 3309 !--------------- 3310 ! b = product of matrix A times vector x in full format 3311 ! 3312 ! Algorithm: 3313 !--------------- 3314 ! Perform multiplication by traversing a in order. 3315 ! 3316 !----------------------------------------------------------------------- 3317 !-----local variables 3318 integer n, i, j, ii, jj, k, istart, istop 3319 real*8 xjj 3320 !--------------------------------- 3321 n = kvstc(nc+1)-1 3322 do i = 1, n 3323 b(i) = 0.d0 3324 enddo 3325 !--------------------------------- 3326 k = 1 3327 do i = 1, nr 3328 istart = kvstr(i) 3329 istop = kvstr(i+1)-1 3330 do j = ia(i), ia(i+1)-1 3331 do jj = kvstc(ja(j)), kvstc(ja(j)+1)-1 3332 xjj = x(jj) 3333 do ii = istart, istop 3334 b(ii) = b(ii) + xjj*a(k) 3335 k = k + 1 3336 enddo 3337 enddo 3338 enddo 3339 enddo 3340 !--------------------------------- 3341 return 3342 end Page 101 Source Listing VBRMV 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name vbrmv_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References A Dummy 3295 R(8) 8 1 0 ARG,INOUT 3334 B Dummy 3295 R(8) 8 1 0 ARG,INOUT 3323,3334 I Local 3318 I(4) 4 scalar 3322,3323,3327,3328,3329,3330 IA Dummy 3295 I(4) 4 1 0 ARG,INOUT 3330 II Local 3318 I(4) 4 scalar 3333,3334 ISTART Local 3318 I(4) 4 scalar 3328,3333 ISTOP Local 3318 I(4) 4 scalar 3329,3333 J Local 3318 I(4) 4 scalar 3330,3331 JA Dummy 3295 I(4) 4 1 0 ARG,INOUT 3331 JJ Local 3318 I(4) 4 scalar 3331,3332 K Local 3318 I(4) 4 scalar 3326,3334,3335 KA Dummy 3295 I(4) 4 1 0 ARG,INOUT KVSTC Dummy 3295 I(4) 4 1 0 ARG,INOUT 3321,3331 KVSTR Dummy 3295 I(4) 4 1 0 ARG,INOUT 3328,3329 N Local 3318 I(4) 4 scalar 3321,3322 NC Dummy 3295 I(4) 4 scalar ARG,INOUT 3321 NR Dummy 3295 I(4) 4 scalar ARG,INOUT 3297,3327 VBRMV Subr 3295 X Dummy 3295 R(8) 8 1 0 ARG,INOUT 3332 XJJ Local 3319 R(8) 8 scalar 3332,3334 Page 102 Source Listing VBRMV 2014-09-16 16:49 w3profsmd.f90 3343 !----------------------------------------------------------------------- 3344 !----------------------end-of-vbrmv------------------------------------- 3345 !----------------------------------------------------------------------- 3346 !----------------------------------------------------------------------c 3347 ! 2) T R I A N G U L A R S Y S T E M S O L U T I O N S c 3348 !----------------------------------------------------------------------c 3349 subroutine lsol (n,x,y,al,jal,ial) 3350 integer n, jal(*),ial(n+1) 3351 real*8 x(n), y(n), al(*) 3352 !----------------------------------------------------------------------- 3353 ! solves L x = y ; L = lower unit triang. / CSR format 3354 !----------------------------------------------------------------------- 3355 ! solves a unit lower triangular system by standard (sequential ) 3356 ! forward elimination - matrix stored in CSR format. 3357 !----------------------------------------------------------------------- 3358 ! 3359 ! On entry: 3360 !---------- 3361 ! n = integer. dimension of problem. 3362 ! y = real array containg the right side. 3363 ! 3364 ! al, 3365 ! jal, 3366 ! ial, = Lower triangular matrix stored in compressed sparse row 3367 ! format. 3368 ! 3369 ! On return: 3370 !----------- 3371 ! x = The solution of L x = y. 3372 !-------------------------------------------------------------------- 3373 ! local variables 3374 ! 3375 integer k, j 3376 real*8 t 3377 !----------------------------------------------------------------------- 3378 x(1) = y(1) 3379 do 150 k = 2, n 3380 t = y(k) 3381 do 100 j = ial(k), ial(k+1)-1 3382 t = t-al(j)*x(jal(j)) 3383 100 continue 3384 x(k) = t 3385 150 continue 3386 ! 3387 return 3388 !----------end-of-lsol-------------------------------------------------- 3389 !----------------------------------------------------------------------- 3390 end Page 103 Source Listing LSOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name lsol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3383 3381 150 Label 3385 3379 AL Dummy 3349 R(8) 8 1 0 ARG,INOUT 3382 IAL Dummy 3349 I(4) 4 1 0 ARG,INOUT 3381 J Local 3375 I(4) 4 scalar 3381,3382 JAL Dummy 3349 I(4) 4 1 0 ARG,INOUT 3382 K Local 3375 I(4) 4 scalar 3379,3380,3381,3384 LSOL Subr 3349 N Dummy 3349 I(4) 4 scalar ARG,INOUT 3350,3351,3379 T Local 3376 R(8) 8 scalar 3380,3382,3384 X Dummy 3349 R(8) 8 1 0 ARG,INOUT 3378,3382,3384 Y Dummy 3349 R(8) 8 1 0 ARG,INOUT 3378,3380 Page 104 Source Listing LSOL 2014-09-16 16:49 w3profsmd.f90 3391 !----------------------------------------------------------------------- 3392 subroutine ldsol (n,x,y,al,jal) 3393 integer n, jal(*) 3394 real*8 x(n), y(n), al(*) 3395 !----------------------------------------------------------------------- 3396 ! Solves L x = y L = triangular. MSR format 3397 !----------------------------------------------------------------------- 3398 ! solves a (non-unit) lower triangular system by standard (sequential) 3399 ! forward elimination - matrix stored in MSR format 3400 ! with diagonal elements already inverted (otherwise do inversion, 3401 ! al(1:n) = 1.0/al(1:n), before calling ldsol). 3402 !----------------------------------------------------------------------- 3403 ! 3404 ! On entry: 3405 !---------- 3406 ! n = integer. dimension of problem. 3407 ! y = real array containg the right hand side. 3408 ! 3409 ! al, 3410 ! jal, = Lower triangular matrix stored in Modified Sparse Row 3411 ! format. 3412 ! 3413 ! On return: 3414 !----------- 3415 ! x = The solution of L x = y . 3416 !-------------------------------------------------------------------- 3417 ! local variables 3418 ! 3419 integer k, j 3420 real*8 t 3421 !----------------------------------------------------------------------- 3422 x(1) = y(1)*al(1) 3423 do 150 k = 2, n 3424 t = y(k) 3425 do 100 j = jal(k), jal(k+1)-1 3426 t = t - al(j)*x(jal(j)) 3427 100 continue 3428 x(k) = al(k)*t 3429 150 continue 3430 return 3431 !----------end-of-ldsol------------------------------------------------- 3432 !----------------------------------------------------------------------- 3433 end Page 105 Source Listing LDSOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name ldsol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3427 3425 150 Label 3429 3423 AL Dummy 3392 R(8) 8 1 0 ARG,INOUT 3422,3426,3428 J Local 3419 I(4) 4 scalar 3425,3426 JAL Dummy 3392 I(4) 4 1 0 ARG,INOUT 3425,3426 K Local 3419 I(4) 4 scalar 3423,3424,3425,3428 LDSOL Subr 3392 N Dummy 3392 I(4) 4 scalar ARG,INOUT 3394,3423 T Local 3420 R(8) 8 scalar 3424,3426,3428 X Dummy 3392 R(8) 8 1 0 ARG,INOUT 3422,3426,3428 Y Dummy 3392 R(8) 8 1 0 ARG,INOUT 3422,3424 Page 106 Source Listing LDSOL 2014-09-16 16:49 w3profsmd.f90 3434 !----------------------------------------------------------------------- 3435 subroutine lsolc (n,x,y,al,jal,ial) 3436 integer n, jal(*),ial(*) 3437 real*8 x(n), y(n), al(*) 3438 !----------------------------------------------------------------------- 3439 ! SOLVES L x = y ; where L = unit lower trang. CSC format 3440 !----------------------------------------------------------------------- 3441 ! solves a unit lower triangular system by standard (sequential ) 3442 ! forward elimination - matrix stored in CSC format. 3443 !----------------------------------------------------------------------- 3444 ! 3445 ! On entry: 3446 !---------- 3447 ! n = integer. dimension of problem. 3448 ! y = real*8 array containg the right side. 3449 ! 3450 ! al, 3451 ! jal, 3452 ! ial, = Lower triangular matrix stored in compressed sparse column 3453 ! format. 3454 ! 3455 ! On return: 3456 !----------- 3457 ! x = The solution of L x = y. 3458 !----------------------------------------------------------------------- 3459 ! local variables 3460 ! 3461 integer k, j 3462 real*8 t 3463 !----------------------------------------------------------------------- 3464 do 140 k=1,n 3465 x(k) = y(k) 3466 140 continue 3467 do 150 k = 1, n-1 3468 t = x(k) 3469 do 100 j = ial(k), ial(k+1)-1 3470 x(jal(j)) = x(jal(j)) - t*al(j) 3471 100 continue 3472 150 continue 3473 ! 3474 return 3475 !----------end-of-lsolc------------------------------------------------- 3476 !----------------------------------------------------------------------- 3477 end Page 107 Source Listing LSOLC 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name lsolc_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3471 3469 140 Label 3466 3464 150 Label 3472 3467 AL Dummy 3435 R(8) 8 1 0 ARG,INOUT 3470 IAL Dummy 3435 I(4) 4 1 0 ARG,INOUT 3469 J Local 3461 I(4) 4 scalar 3469,3470 JAL Dummy 3435 I(4) 4 1 0 ARG,INOUT 3470 K Local 3461 I(4) 4 scalar 3464,3465,3467,3468,3469 LSOLC Subr 3435 N Dummy 3435 I(4) 4 scalar ARG,INOUT 3437,3464,3467 T Local 3462 R(8) 8 scalar 3468,3470 X Dummy 3435 R(8) 8 1 0 ARG,INOUT 3465,3468,3470 Y Dummy 3435 R(8) 8 1 0 ARG,INOUT 3465 Page 108 Source Listing LSOLC 2014-09-16 16:49 w3profsmd.f90 3478 !----------------------------------------------------------------------- 3479 subroutine ldsolc (n,x,y,al,jal) 3480 integer n, jal(*) 3481 real*8 x(n), y(n), al(*) 3482 !----------------------------------------------------------------------- 3483 ! Solves L x = y ; L = nonunit Low. Triang. MSC format 3484 !----------------------------------------------------------------------- 3485 ! solves a (non-unit) lower triangular system by standard (sequential) 3486 ! forward elimination - matrix stored in Modified Sparse Column format 3487 ! with diagonal elements already inverted (otherwise do inversion, 3488 ! al(1:n) = 1.0/al(1:n), before calling ldsol). 3489 !----------------------------------------------------------------------- 3490 ! 3491 ! On entry: 3492 !---------- 3493 ! n = integer. dimension of problem. 3494 ! y = real array containg the right hand side. 3495 ! 3496 ! al, 3497 ! jal, 3498 ! ial, = Lower triangular matrix stored in Modified Sparse Column 3499 ! format. 3500 ! 3501 ! On return: 3502 !----------- 3503 ! x = The solution of L x = y . 3504 !-------------------------------------------------------------------- 3505 ! local variables 3506 ! 3507 integer k, j 3508 real*8 t 3509 !----------------------------------------------------------------------- 3510 do 140 k=1,n 3511 x(k) = y(k) 3512 140 continue 3513 do 150 k = 1, n 3514 x(k) = x(k)*al(k) 3515 t = x(k) 3516 do 100 j = jal(k), jal(k+1)-1 3517 x(jal(j)) = x(jal(j)) - t*al(j) 3518 100 continue 3519 150 continue 3520 ! 3521 return 3522 !----------end-of-lsolc------------------------------------------------ 3523 !----------------------------------------------------------------------- 3524 end Page 109 Source Listing LDSOLC 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name ldsolc_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3518 3516 140 Label 3512 3510 150 Label 3519 3513 AL Dummy 3479 R(8) 8 1 0 ARG,INOUT 3514,3517 J Local 3507 I(4) 4 scalar 3516,3517 JAL Dummy 3479 I(4) 4 1 0 ARG,INOUT 3516,3517 K Local 3507 I(4) 4 scalar 3510,3511,3513,3514,3515,3516 LDSOLC Subr 3479 N Dummy 3479 I(4) 4 scalar ARG,INOUT 3481,3510,3513 T Local 3508 R(8) 8 scalar 3515,3517 X Dummy 3479 R(8) 8 1 0 ARG,INOUT 3511,3514,3515,3517 Y Dummy 3479 R(8) 8 1 0 ARG,INOUT 3511 Page 110 Source Listing LDSOLC 2014-09-16 16:49 w3profsmd.f90 3525 !----------------------------------------------------------------------- 3526 subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev) 3527 integer n, nlev, jal(*), ilev(nlev+1), lev(n) 3528 real*8 x(n), y(n), al(*) 3529 !----------------------------------------------------------------------- 3530 ! Solves L x = y L = triangular. Uses LEVEL SCHEDULING/MSR format 3531 !----------------------------------------------------------------------- 3532 ! 3533 ! On entry: 3534 !---------- 3535 ! n = integer. dimension of problem. 3536 ! y = real array containg the right hand side. 3537 ! 3538 ! al, 3539 ! jal, = Lower triangular matrix stored in Modified Sparse Row 3540 ! format. 3541 ! nlev = number of levels in matrix 3542 ! lev = integer array of length n, containing the permutation 3543 ! that defines the levels in the level scheduling ordering. 3544 ! ilev = pointer to beginning of levels in lev. 3545 ! the numbers lev(i) to lev(i+1)-1 contain the row numbers 3546 ! that belong to level number i, in the level shcheduling 3547 ! ordering. 3548 ! 3549 ! On return: 3550 !----------- 3551 ! x = The solution of L x = y . 3552 !-------------------------------------------------------------------- 3553 integer ii, jrow, i 3554 real*8 t 3555 ! 3556 ! outer loop goes through the levels. (SEQUENTIAL loop) 3557 ! 3558 do 150 ii=1, nlev 3559 ! 3560 ! next loop executes within the same level. PARALLEL loop 3561 ! 3562 do 100 i=ilev(ii), ilev(ii+1)-1 3563 jrow = lev(i) 3564 ! 3565 ! compute inner product of row jrow with x 3566 ! 3567 t = y(jrow) 3568 do 130 k=jal(jrow), jal(jrow+1)-1 3569 t = t - al(k)*x(jal(k)) 3570 130 continue 3571 x(jrow) = t*al(jrow) 3572 100 continue 3573 150 continue 3574 return 3575 !----------------------------------------------------------------------- 3576 end Page 111 Source Listing LDSOLL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name ldsoll_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3572 3562 130 Label 3570 3568 150 Label 3573 3558 AL Dummy 3526 R(8) 8 1 0 ARG,INOUT 3569,3571 I Local 3553 I(4) 4 scalar 3562,3563 II Local 3553 I(4) 4 scalar 3558,3562 ILEV Dummy 3526 I(4) 4 1 0 ARG,INOUT 3562 JAL Dummy 3526 I(4) 4 1 0 ARG,INOUT 3568,3569 JROW Local 3553 I(4) 4 scalar 3563,3567,3568,3571 K Local 3568 I(4) 4 scalar 3568,3569 LDSOLL Subr 3526 LEV Dummy 3526 I(4) 4 1 0 ARG,INOUT 3563 N Dummy 3526 I(4) 4 scalar ARG,INOUT 3527,3528 NLEV Dummy 3526 I(4) 4 scalar ARG,INOUT 3527,3558 T Local 3554 R(8) 8 scalar 3567,3569,3571 X Dummy 3526 R(8) 8 1 0 ARG,INOUT 3569,3571 Y Dummy 3526 R(8) 8 1 0 ARG,INOUT 3567 Page 112 Source Listing LDSOLL 2014-09-16 16:49 w3profsmd.f90 3577 !----------------------------------------------------------------------- 3578 subroutine usol (n,x,y,au,jau,iau) 3579 integer n, jau(*),iau(n+1) 3580 real*8 x(n), y(n), au(*) 3581 !----------------------------------------------------------------------- 3582 ! Solves U x = y U = unit upper triangular. 3583 !----------------------------------------------------------------------- 3584 ! solves a unit upper triangular system by standard (sequential ) 3585 ! backward elimination - matrix stored in CSR format. 3586 !----------------------------------------------------------------------- 3587 ! 3588 ! On entry: 3589 !---------- 3590 ! n = integer. dimension of problem. 3591 ! y = real array containg the right side. 3592 ! 3593 ! au, 3594 ! jau, 3595 ! iau, = Lower triangular matrix stored in compressed sparse row 3596 ! format. 3597 ! 3598 ! On return: 3599 !----------- 3600 ! x = The solution of U x = y . 3601 !-------------------------------------------------------------------- 3602 ! local variables 3603 ! 3604 integer k, j 3605 real*8 t 3606 !----------------------------------------------------------------------- 3607 x(n) = y(n) 3608 do 150 k = n-1,1,-1 3609 t = y(k) 3610 do 100 j = iau(k), iau(k+1)-1 3611 t = t - au(j)*x(jau(j)) 3612 100 continue 3613 x(k) = t 3614 150 continue 3615 ! 3616 return 3617 !----------end-of-usol-------------------------------------------------- 3618 !----------------------------------------------------------------------- 3619 end Page 113 Source Listing USOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name usol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3612 3610 150 Label 3614 3608 AU Dummy 3578 R(8) 8 1 0 ARG,INOUT 3611 IAU Dummy 3578 I(4) 4 1 0 ARG,INOUT 3610 J Local 3604 I(4) 4 scalar 3610,3611 JAU Dummy 3578 I(4) 4 1 0 ARG,INOUT 3611 K Local 3604 I(4) 4 scalar 3608,3609,3610,3613 N Dummy 3578 I(4) 4 scalar ARG,INOUT 3579,3580,3607,3608 T Local 3605 R(8) 8 scalar 3609,3611,3613 USOL Subr 3578 X Dummy 3578 R(8) 8 1 0 ARG,INOUT 3607,3611,3613 Y Dummy 3578 R(8) 8 1 0 ARG,INOUT 3607,3609 Page 114 Source Listing USOL 2014-09-16 16:49 w3profsmd.f90 3620 !----------------------------------------------------------------------- 3621 subroutine udsol (n,x,y,au,jau) 3622 integer n, jau(*) 3623 real*8 x(n), y(n),au(*) 3624 !----------------------------------------------------------------------- 3625 ! Solves U x = y ; U = upper triangular in MSR format 3626 !----------------------------------------------------------------------- 3627 ! solves a non-unit upper triangular matrix by standard (sequential ) 3628 ! backward elimination - matrix stored in MSR format. 3629 ! with diagonal elements already inverted (otherwise do inversion, 3630 ! au(1:n) = 1.0/au(1:n), before calling). 3631 !----------------------------------------------------------------------- 3632 ! 3633 ! On entry: 3634 !---------- 3635 ! n = integer. dimension of problem. 3636 ! y = real array containg the right side. 3637 ! 3638 ! au, 3639 ! jau, = Lower triangular matrix stored in modified sparse row 3640 ! format. 3641 ! 3642 ! On return: 3643 !----------- 3644 ! x = The solution of U x = y . 3645 !-------------------------------------------------------------------- 3646 ! local variables 3647 ! 3648 integer k, j 3649 real*8 t 3650 !----------------------------------------------------------------------- 3651 x(n) = y(n)*au(n) 3652 do 150 k = n-1,1,-1 3653 t = y(k) 3654 do 100 j = jau(k), jau(k+1)-1 3655 t = t - au(j)*x(jau(j)) 3656 100 continue 3657 x(k) = au(k)*t 3658 150 continue 3659 ! 3660 return 3661 !----------end-of-udsol------------------------------------------------- 3662 !----------------------------------------------------------------------- 3663 end Page 115 Source Listing UDSOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name udsol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3656 3654 150 Label 3658 3652 AU Dummy 3621 R(8) 8 1 0 ARG,INOUT 3651,3655,3657 J Local 3648 I(4) 4 scalar 3654,3655 JAU Dummy 3621 I(4) 4 1 0 ARG,INOUT 3654,3655 K Local 3648 I(4) 4 scalar 3652,3653,3654,3657 N Dummy 3621 I(4) 4 scalar ARG,INOUT 3623,3651,3652 T Local 3649 R(8) 8 scalar 3653,3655,3657 UDSOL Subr 3621 X Dummy 3621 R(8) 8 1 0 ARG,INOUT 3651,3655,3657 Y Dummy 3621 R(8) 8 1 0 ARG,INOUT 3651,3653 Page 116 Source Listing UDSOL 2014-09-16 16:49 w3profsmd.f90 3664 !----------------------------------------------------------------------- 3665 subroutine usolc (n,x,y,au,jau,iau) 3666 real*8 x(*), y(*), au(*) 3667 integer n, jau(*),iau(*) 3668 !----------------------------------------------------------------------- 3669 ! SOUVES U x = y ; where U = unit upper trang. CSC format 3670 !----------------------------------------------------------------------- 3671 ! solves a unit upper triangular system by standard (sequential ) 3672 ! forward elimination - matrix stored in CSC format. 3673 !----------------------------------------------------------------------- 3674 ! 3675 ! On entry: 3676 !---------- 3677 ! n = integer. dimension of problem. 3678 ! y = real*8 array containg the right side. 3679 ! 3680 ! au, 3681 ! jau, 3682 ! iau, = Uower triangular matrix stored in compressed sparse column 3683 ! format. 3684 ! 3685 ! On return: 3686 !----------- 3687 ! x = The solution of U x = y. 3688 !----------------------------------------------------------------------- 3689 ! local variables 3690 ! 3691 integer k, j 3692 real*8 t 3693 !----------------------------------------------------------------------- 3694 do 140 k=1,n 3695 x(k) = y(k) 3696 140 continue 3697 do 150 k = n,1,-1 3698 t = x(k) 3699 do 100 j = iau(k), iau(k+1)-1 3700 x(jau(j)) = x(jau(j)) - t*au(j) 3701 100 continue 3702 150 continue 3703 ! 3704 return 3705 !----------end-of-usolc------------------------------------------------- 3706 !----------------------------------------------------------------------- 3707 end Page 117 Source Listing USOLC 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name usolc_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3701 3699 140 Label 3696 3694 150 Label 3702 3697 AU Dummy 3665 R(8) 8 1 0 ARG,INOUT 3700 IAU Dummy 3665 I(4) 4 1 0 ARG,INOUT 3699 J Local 3691 I(4) 4 scalar 3699,3700 JAU Dummy 3665 I(4) 4 1 0 ARG,INOUT 3700 K Local 3691 I(4) 4 scalar 3694,3695,3697,3698,3699 N Dummy 3665 I(4) 4 scalar ARG,INOUT 3694,3697 T Local 3692 R(8) 8 scalar 3698,3700 USOLC Subr 3665 X Dummy 3665 R(8) 8 1 0 ARG,INOUT 3695,3698,3700 Y Dummy 3665 R(8) 8 1 0 ARG,INOUT 3695 Page 118 Source Listing USOLC 2014-09-16 16:49 w3profsmd.f90 3708 !----------------------------------------------------------------------- 3709 subroutine udsolc (n,x,y,au,jau) 3710 integer n, jau(*) 3711 real*8 x(n), y(n), au(*) 3712 !----------------------------------------------------------------------- 3713 ! Solves U x = y ; U = nonunit Up. Triang. MSC format 3714 !----------------------------------------------------------------------- 3715 ! solves a (non-unit) upper triangular system by standard (sequential) 3716 ! forward elimination - matrix stored in Modified Sparse Column format 3717 ! with diagonal elements already inverted (otherwise do inversion, 3718 ! auuuul(1:n) = 1.0/au(1:n), before calling ldsol). 3719 !----------------------------------------------------------------------- 3720 ! 3721 ! On entry: 3722 !---------- 3723 ! n = integer. dimension of problem. 3724 ! y = real*8 array containg the right hand side. 3725 ! 3726 ! au, 3727 ! jau, = Upper triangular matrix stored in Modified Sparse Column 3728 ! format. 3729 ! 3730 ! On return: 3731 !----------- 3732 ! x = The solution of U x = y . 3733 !-------------------------------------------------------------------- 3734 ! local variables 3735 ! 3736 integer k, j 3737 real*8 t 3738 !----------------------------------------------------------------------- 3739 do 140 k=1,n 3740 x(k) = y(k) 3741 140 continue 3742 do 150 k = n,1,-1 3743 x(k) = x(k)*au(k) 3744 t = x(k) 3745 do 100 j = jau(k), jau(k+1)-1 3746 x(jau(j)) = x(jau(j)) - t*au(j) 3747 100 continue 3748 150 continue 3749 ! 3750 return 3751 !----------end-of-udsolc------------------------------------------------ 3752 !----------------------------------------------------------------------- 3753 end Page 119 Source Listing UDSOLC 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name udsolc_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 100 Label 3747 3745 140 Label 3741 3739 150 Label 3748 3742 AU Dummy 3709 R(8) 8 1 0 ARG,INOUT 3743,3746 J Local 3736 I(4) 4 scalar 3745,3746 JAU Dummy 3709 I(4) 4 1 0 ARG,INOUT 3745,3746 K Local 3736 I(4) 4 scalar 3739,3740,3742,3743,3744,3745 N Dummy 3709 I(4) 4 scalar ARG,INOUT 3711,3739,3742 T Local 3737 R(8) 8 scalar 3744,3746 UDSOLC Subr 3709 X Dummy 3709 R(8) 8 1 0 ARG,INOUT 3740,3743,3744,3746 Y Dummy 3709 R(8) 8 1 0 ARG,INOUT 3740 Page 120 Source Listing UDSOLC 2014-09-16 16:49 w3profsmd.f90 3754 !----------------------------------------------------------------------- 3755 subroutine lusol(n, y, x, alu, jlu, ju) 3756 implicit none 3757 3758 integer :: n, jlu(*), ju(*) 3759 real*8 :: x(n), y(n), alu(*) 3760 3761 !----------------------------------------------------------------------- 3762 integer :: i,k 3763 ! 3764 ! forward solve 3765 ! 3766 do 40 i = 1, n 3767 x(i) = y(i) 3768 do 41 k=jlu(i),ju(i)-1 3769 x(i) = x(i) - alu(k)* x(jlu(k)) 3770 41 continue 3771 40 continue 3772 do 90 i = n, 1, -1 3773 do 91 k=ju(i),jlu(i+1)-1 3774 x(i) = x(i) - alu(k)*x(jlu(k)) 3775 91 continue 3776 x(i) = alu(i)*x(i) 3777 90 continue 3778 ! 3779 return 3780 !----------------end of lusol ------------------------------------------ 3781 end Page 121 Source Listing LUSOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name lusol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 40 Label 3771 3766 41 Label 3770 3768 90 Label 3777 3772 91 Label 3775 3773 ALU Dummy 3755 R(8) 8 1 0 ARG,INOUT 3769,3774,3776 I Local 3762 I(4) 4 scalar 3766,3767,3768,3769,3772,3773,3774 ,3776 JLU Dummy 3755 I(4) 4 1 0 ARG,INOUT 3768,3769,3773,3774 JU Dummy 3755 I(4) 4 1 0 ARG,INOUT 3768,3773 K Local 3762 I(4) 4 scalar 3768,3769,3773,3774 LUSOL Subr 3755 N Dummy 3755 I(4) 4 scalar ARG,INOUT 3759,3766,3772 X Dummy 3755 R(8) 8 1 0 ARG,INOUT 3767,3769,3774,3776 Y Dummy 3755 R(8) 8 1 0 ARG,INOUT 3767 Page 122 Source Listing LUSOL 2014-09-16 16:49 w3profsmd.f90 3782 !----------------------------------------------------------------------- 3783 subroutine lutsol(n, y, x, alu, jlu, ju) 3784 implicit none 3785 3786 integer :: n, jlu(*), ju(*) 3787 real*8 :: x(n), y(n), alu(*) 3788 3789 !----------------------------------------------------------------------- 3790 ! local variables 3791 ! 3792 integer :: i,k 3793 ! 3794 do 10 i = 1, n 3795 x(i) = y(i) 3796 10 continue 3797 ! 3798 ! forward solve (with U^T) 3799 ! 3800 do 20 i = 1, n 3801 x(i) = x(i) * alu(i) 3802 do 30 k=ju(i),jlu(i+1)-1 3803 x(jlu(k)) = x(jlu(k)) - alu(k)* x(i) 3804 30 continue 3805 20 continue 3806 ! 3807 ! backward solve (with L^T) 3808 ! 3809 do 40 i = n, 1, -1 3810 do 50 k=jlu(i),ju(i)-1 3811 x(jlu(k)) = x(jlu(k)) - alu(k)*x(i) 3812 50 continue 3813 40 continue 3814 ! 3815 return 3816 !----------------end of lutsol ----------------------------------------- 3817 !----------------------------------------------------------------------- 3818 end Page 123 Source Listing LUTSOL 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name lutsol_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 3796 3794 20 Label 3805 3800 30 Label 3804 3802 40 Label 3813 3809 50 Label 3812 3810 ALU Dummy 3783 R(8) 8 1 0 ARG,INOUT 3801,3803,3811 I Local 3792 I(4) 4 scalar 3794,3795,3800,3801,3802,3803,3809 ,3810,3811 JLU Dummy 3783 I(4) 4 1 0 ARG,INOUT 3802,3803,3810,3811 JU Dummy 3783 I(4) 4 1 0 ARG,INOUT 3802,3810 K Local 3792 I(4) 4 scalar 3802,3803,3810,3811 LUTSOL Subr 3783 N Dummy 3783 I(4) 4 scalar ARG,INOUT 3787,3794,3800,3809 X Dummy 3783 R(8) 8 1 0 ARG,INOUT 3795,3801,3803,3811 Y Dummy 3783 R(8) 8 1 0 ARG,INOUT 3795 Page 124 Source Listing LUTSOL 2014-09-16 16:49 w3profsmd.f90 3819 !----------------------------------------------------------------------- 3820 subroutine qsplit(a,ind,n,ncut) 3821 implicit none 3822 3823 integer :: n, ind(n), ncut 3824 real*8 :: a(n) 3825 3826 !----------------------------------------------------------------------- 3827 ! does a quick-sort split of a real array. 3828 ! on input a(1:n). is a real array 3829 ! on output a(1:n) is permuted such that its elements satisfy: 3830 ! 3831 ! abs(a(i)) .ge. abs(a(ncut)) for i .lt. ncut and 3832 ! abs(a(i)) .le. abs(a(ncut)) for i .gt. ncut 3833 ! 3834 ! ind(1:n) is an integer array which permuted in the same way as a(*). 3835 !----------------------------------------------------------------------- 3836 real*8 :: tmp, abskey 3837 integer :: itmp, first, last, j, mid 3838 !----- 3839 first = 1 3840 last = n 3841 if (ncut .lt. first .or. ncut .gt. last) return 3842 ! 3843 ! outer loop -- while mid .ne. ncut do 3844 ! 3845 1 mid = first 3846 abskey = abs(a(mid)) 3847 do 2 j=first+1, last 3848 if (abs(a(j)) .gt. abskey) then 3849 mid = mid+1 3850 ! interchange 3851 tmp = a(mid) 3852 itmp = ind(mid) 3853 a(mid) = a(j) 3854 ind(mid) = ind(j) 3855 a(j) = tmp 3856 ind(j) = itmp 3857 endif 3858 2 continue 3859 ! 3860 ! interchange 3861 ! 3862 tmp = a(mid) 3863 a(mid) = a(first) 3864 a(first) = tmp 3865 ! 3866 itmp = ind(mid) 3867 ind(mid) = ind(first) 3868 ind(first) = itmp 3869 ! 3870 ! test for while loop 3871 ! 3872 if (mid .eq. ncut) return 3873 if (mid .gt. ncut) then 3874 last = mid-1 3875 else Page 125 Source Listing QSPLIT 2014-09-16 16:49 w3profsmd.f90 3876 first = mid+1 3877 endif 3878 goto 1 3879 !----------------end-of-qsplit------------------------------------------ 3880 !----------------------------------------------------------------------- 3881 end ENTRY POINTS Name qsplit_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 3845 3878 2 Label 3858 3847 A Dummy 3820 R(8) 8 1 0 ARG,INOUT 3846,3848,3851,3853,3855,3862,3863 ,3864 ABS Func 3846 scalar 3846,3848 ABSKEY Local 3836 R(8) 8 scalar 3846,3848 FIRST Local 3837 I(4) 4 scalar 3839,3841,3845,3847,3863,3864,3867 ,3868,3876 IND Dummy 3820 I(4) 4 1 0 ARG,INOUT 3852,3854,3856,3866,3867,3868 ITMP Local 3837 I(4) 4 scalar 3852,3856,3866,3868 J Local 3837 I(4) 4 scalar 3847,3848,3853,3854,3855,3856 LAST Local 3837 I(4) 4 scalar 3840,3841,3847,3874 MID Local 3837 I(4) 4 scalar 3845,3846,3849,3851,3852,3853,3854 ,3862,3863,3866,3867,3872,3873,387 4,3876 N Dummy 3820 I(4) 4 scalar ARG,INOUT 3823,3824,3840 NCUT Dummy 3820 I(4) 4 scalar ARG,INOUT 3841,3872,3873 QSPLIT Subr 3820 TMP Local 3836 R(8) 8 scalar 3851,3855,3862,3864 Page 126 Source Listing RUNRC 2014-09-16 16:49 w3profsmd.f90 3882 subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver) 3883 implicit none 3884 integer n,ipar(16),ia(n+1),ja(*),ju(*),jau(*) 3885 real*8 fpar(16),rhs(n),sol(n),guess(n),wk(*),a(*),au(*) 3886 external solver 3887 !----------------------------------------------------------------------- 3888 ! the actual tester. It starts the iterative linear system solvers 3889 ! with a initial guess suppied by the user. 3890 ! 3891 ! The structure {au, jau, ju} is assumed to have the output from 3892 ! the ILU* routines in ilut.f. 3893 ! 3894 !----------------------------------------------------------------------- 3895 ! local variables 3896 ! 3897 integer :: i, its 3898 ! real :: dtime, dt(2), time 3899 ! external dtime 3900 save its 3901 ! 3902 ! ipar(2) can be 0, 1, 2, please don't use 3 3903 ! 3904 if (ipar(2).gt.2) then 3905 print *, 'I can not do both left and right preconditioning.' 3906 return 3907 endif 3908 3909 its = 0 3910 ! 3911 do i = 1, n 3912 sol(i) = guess(i) 3913 enddo 3914 ! 3915 ipar(1) = 0 3916 ! time = dtime(dt) 3917 3918 10 call solver(n,rhs,sol,ipar,fpar,wk) 3919 3920 if (ipar(7).ne.its) then 3921 its = ipar(7) 3922 endif 3923 if (ipar(1).eq.1) then 3924 call amux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) 3925 goto 10 3926 else if (ipar(1).eq.2) then 3927 call atmux(n, wk(ipar(8)), wk(ipar(9)), a, ja, ia) 3928 goto 10 3929 else if (ipar(1).eq.3 .or. ipar(1).eq.5) then 3930 call lusol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) 3931 goto 10 3932 else if (ipar(1).eq.4 .or. ipar(1).eq.6) then 3933 call lutsol(n,wk(ipar(8)),wk(ipar(9)),au,jau,ju) 3934 goto 10 3935 else if (ipar(1).le.0) then 3936 if (ipar(1).eq.0) then 3937 ! print *, 'Iterative sovler has satisfied convergence test.' 3938 else if (ipar(1).eq.-1) then Page 127 Source Listing RUNRC 2014-09-16 16:49 w3profsmd.f90 3939 print *, 'Iterative solver has iterated too many times.' 3940 else if (ipar(1).eq.-2) then 3941 print *, 'Iterative solver was not given enough work space.' 3942 print *, 'The work space should at least have ', ipar(4), & 3943 & ' elements.' 3944 else if (ipar(1).eq.-3) then 3945 print *, 'Iterative sovler is facing a break-down.' 3946 else 3947 print *, 'Iterative solver terminated. code =', ipar(1) 3948 endif 3949 endif 3950 end ENTRY POINTS Name runrc_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 3918 3925,3928,3931,3934 A Dummy 3882 R(8) 8 1 0 ARG,INOUT 3924,3927 AMUX Subr 3924 3924 ATMUX Subr 3927 3927 AU Dummy 3882 R(8) 8 1 0 ARG,INOUT 3930,3933 FPAR Dummy 3882 R(8) 8 1 16 ARG,INOUT 3918 GUESS Dummy 3882 R(8) 8 1 0 ARG,INOUT 3912 I Local 3897 I(4) 4 scalar 3911,3912 IA Dummy 3882 I(4) 4 1 0 ARG,INOUT 3924,3927 IPAR Dummy 3882 I(4) 4 1 16 ARG,INOUT 3904,3915,3918,3920,3921,3923,3924 ,3926,3927,3929,3930,3932,3933,393 5,3936,3938,3940,3942,3944,3947 ITS Local 3897 I(4) 4 scalar 3909,3920,3921 JA Dummy 3882 I(4) 4 1 0 ARG,INOUT 3924,3927 JAU Dummy 3882 I(4) 4 1 0 ARG,INOUT 3930,3933 JU Dummy 3882 I(4) 4 1 0 ARG,INOUT 3930,3933 LUSOL Subr 3930 3930 LUTSOL Subr 3933 3933 N Dummy 3882 I(4) 4 scalar ARG,INOUT 3884,3885,3911,3918,3924,3927,3930 ,3933 RHS Dummy 3882 R(8) 8 1 0 ARG,INOUT 3918 RUNRC Subr 3882 SOL Dummy 3882 R(8) 8 1 0 ARG,INOUT 3912,3918 SOLVER Subr 3882 ARG,INOUT 3918 WK Dummy 3882 R(8) 8 1 0 ARG,INOUT 3918,3924,3927,3930,3933 Page 128 Source Listing RUNRC 2014-09-16 16:49 w3profsmd.f90 3951 !-----end-of-runrc 3952 !----------------------------------------------------------------------c 3953 ! S P A R S K I T c 3954 !----------------------------------------------------------------------c 3955 ! ITERATIVE SOLVERS MODULE c 3956 !----------------------------------------------------------------------c 3957 ! This Version Dated: August 13, 1996. Warning: meaning of some c 3958 ! ============ arguments have changed w.r.t. earlier versions. Some c 3959 ! Calling sequences may also have changed c 3960 ! 3961 subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) 3962 !----------------------------------------------------------------------- 3963 implicit none 3964 integer n 3965 real*8 a(*),alu(*),w(n+1),droptol 3966 integer ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),lfil,iwk,ierr 3967 !----------------------------------------------------------------------* 3968 ! *** ILUT preconditioner *** * 3969 ! incomplete LU factorization with dual truncation mechanism * 3970 !----------------------------------------------------------------------* 3971 ! Author: Yousef Saad *May, 5, 1990, Latest revision, August 1996 * 3972 !----------------------------------------------------------------------* 3973 ! PARAMETERS 3974 !----------- 3975 ! 3976 ! on entry: 3977 !========== 3978 ! n = integer. The row dimension of the matrix A. The matrix 3979 ! 3980 ! a,ja,ia = matrix stored in Compressed Sparse Row format. 3981 ! 3982 ! lfil = integer. The fill-in parameter. Each row of L and each row 3983 ! of U will have a maximum of lfil elements (excluding the 3984 ! diagonal element). lfil must be .ge. 0. 3985 ! ** WARNING: THE MEANING OF LFIL HAS CHANGED WITH RESPECT TO 3986 ! EARLIER VERSIONS. 3987 ! 3988 ! droptol = real*8. Sets the threshold for dropping small terms in the 3989 ! factorization. See below for details on dropping strategy. 3990 ! 3991 ! iwk = integer. The lengths of arrays alu and jlu. If the arrays 3992 ! are not big enough to store the ILU factorizations, ilut 3993 ! will stop with an error message. 3994 ! 3995 ! On return: 3996 !=========== 3997 ! 3998 ! alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing 3999 ! the L and U factors together. The diagonal (stored in 4000 ! alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix 4001 ! contains the i-th row of L (excluding the diagonal entry=1) 4002 ! followed by the i-th row of U. 4003 ! 4004 ! ju = integer array of length n containing the pointers to 4005 ! the beginning of each row of U in the matrix alu,jlu. 4006 ! 4007 ! ierr = integer. Error message with the following meaning. Page 129 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4008 ! ierr = 0 --> successful return. 4009 ! ierr .gt. 0 --> zero pivot encountered at step number ierr. 4010 ! ierr = -1 --> Error. input matrix may be wrong. 4011 ! (The elimination process has generated a 4012 ! row in L or U whose length is .gt. n.) 4013 ! ierr = -2 --> The matrix L overflows the array al. 4014 ! ierr = -3 --> The matrix U overflows the array alu. 4015 ! ierr = -4 --> Illegal value for lfil. 4016 ! ierr = -5 --> zero row encountered. 4017 ! 4018 ! work arrays: 4019 !============= 4020 ! jw = integer work array of length 2*n. 4021 ! w = real work array of length n+1. 4022 ! 4023 !---------------------------------------------------------------------- 4024 ! w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u] 4025 ! jw(n+1:2n) stores nonzero indicators 4026 ! 4027 ! Notes: 4028 ! ------ 4029 ! The diagonal elements of the input matrix must be nonzero (at least 4030 ! 'structurally'). 4031 ! 4032 !----------------------------------------------------------------------* 4033 !---- Dual drop strategy works as follows. * 4034 ! * 4035 ! 1) Theresholding in L and U as set by droptol. Any element whose * 4036 ! magnitude is less than some tolerance (relative to the abs * 4037 ! value of diagonal element in u) is dropped. * 4038 ! * 4039 ! 2) Keeping only the largest lfil elements in the i-th row of L * 4040 ! and the largest lfil elements in the i-th row of U (excluding * 4041 ! diagonal elements). * 4042 ! * 4043 ! Flexibility: one can use droptol=0 to get a strategy based on * 4044 ! keeping the largest elements in each row of L and U. Taking * 4045 ! droptol .ne. 0 but lfil=n will give the usual threshold strategy * 4046 ! (however, fill-in is then mpredictible). * 4047 !----------------------------------------------------------------------* 4048 ! locals 4049 integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,lenn 4050 real*8 tnorm, t, abs, s, fact 4051 if (lfil .lt. 0) goto 998 4052 !----------------------------------------------------------------------- 4053 ! initialize ju0 (points to next element to be added to alu,jlu) 4054 ! and pointer array. 4055 !----------------------------------------------------------------------- 4056 ju0 = n+2 4057 jlu(1) = ju0 4058 ! 4059 ! initialize nonzero indicator array. 4060 ! 4061 do 1 j=1,n 4062 jw(n+j) = 0 4063 1 continue 4064 !----------------------------------------------------------------------- Page 130 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4065 ! beginning of main loop. 4066 !----------------------------------------------------------------------- 4067 do 500 ii = 1, n 4068 4069 j1 = ia(ii) 4070 j2 = ia(ii+1) - 1 4071 4072 tnorm = 0.0d0 4073 do 501 k=j1,j2 4074 tnorm = tnorm+abs(a(k)) 4075 501 continue 4076 if (abs(tnorm) .lt. tiny(1.)) goto 999 4077 4078 tnorm = tnorm/real(j2-j1+1) 4079 ! 4080 ! unpack L-part and U-part of row of A in arrays w 4081 ! 4082 lenu = 1 4083 lenl = 0 4084 jw(ii) = ii 4085 w(ii) = 0.0 4086 jw(n+ii) = ii 4087 ! 4088 do 170 j = j1, j2 4089 k = ja(j) 4090 t = a(j) 4091 if (k .lt. ii) then 4092 lenl = lenl+1 4093 jw(lenl) = k 4094 w(lenl) = t 4095 jw(n+k) = lenl 4096 else if (k .eq. ii) then 4097 w(ii) = t 4098 else 4099 lenu = lenu+1 4100 jpos = ii+lenu-1 4101 jw(jpos) = k 4102 w(jpos) = t 4103 jw(n+k) = jpos 4104 endif 4105 170 continue 4106 jj = 0 4107 lenn = 0 4108 ! 4109 ! eliminate previous rows 4110 ! 4111 150 jj = jj+1 4112 if (jj .gt. lenl) goto 160 4113 !----------------------------------------------------------------------- 4114 ! in order to do the elimination in the correct order we must select 4115 ! the smallest column index among jw(k), k=jj+1, ..., lenl. 4116 !----------------------------------------------------------------------- 4117 jrow = jw(jj) 4118 k = jj 4119 ! 4120 ! determine smallest column index 4121 ! Page 131 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4122 do 151 j=jj+1,lenl 4123 if (jw(j) .lt. jrow) then 4124 jrow = jw(j) 4125 k = j 4126 endif 4127 151 continue 4128 ! 4129 if (k .ne. jj) then 4130 ! exchange in jw 4131 j = jw(jj) 4132 jw(jj) = jw(k) 4133 jw(k) = j 4134 ! exchange in jr 4135 jw(n+jrow) = jj 4136 jw(n+j) = k 4137 ! exchange in w 4138 s = w(jj) 4139 w(jj) = w(k) 4140 w(k) = s 4141 endif 4142 ! 4143 ! zero out element in row by setting jw(n+jrow) to zero. 4144 ! 4145 jw(n+jrow) = 0 4146 ! 4147 ! get the multiplier for row to be eliminated (jrow). 4148 ! 4149 fact = w(jj)*alu(jrow) 4150 if (abs(fact) .le. droptol) goto 150 4151 ! 4152 ! combine current row and row jrow 4153 ! 4154 do 203 k = ju(jrow), jlu(jrow+1)-1 4155 s = fact*alu(k) 4156 j = jlu(k) 4157 jpos = jw(n+j) 4158 if (j .ge. ii) then 4159 ! 4160 ! dealing with upper part. 4161 ! 4162 if (jpos .eq. 0) then 4163 ! 4164 ! this is a fill-in element 4165 ! 4166 lenu = lenu+1 4167 if (lenu .gt. n) goto 995 4168 i = ii+lenu-1 4169 jw(i) = j 4170 jw(n+j) = i 4171 w(i) = - s 4172 else 4173 ! 4174 ! this is not a fill-in element 4175 ! 4176 w(jpos) = w(jpos) - s 4177 4178 endif Page 132 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4179 else 4180 ! 4181 ! dealing with lower part. 4182 ! 4183 if (jpos .eq. 0) then 4184 ! 4185 ! this is a fill-in element 4186 ! 4187 lenl = lenl+1 4188 if (lenl .gt. n) goto 995 4189 jw(lenl) = j 4190 jw(n+j) = lenl 4191 w(lenl) = - s 4192 else 4193 ! 4194 ! this is not a fill-in element 4195 ! 4196 w(jpos) = w(jpos) - s 4197 endif 4198 endif 4199 203 continue 4200 ! 4201 ! store this pivot element -- (from left to right -- no danger of 4202 ! overlap with the working elements in L (pivots). 4203 ! 4204 lenn = lenn+1 4205 w(lenn) = fact 4206 jw(lenn) = jrow 4207 goto 150 4208 160 continue 4209 ! 4210 ! reset double-pointer to zero (U-part) 4211 ! 4212 do 308 k=1, lenu 4213 jw(n+jw(ii+k-1)) = 0 4214 308 continue 4215 ! 4216 ! update L-matrix 4217 ! 4218 lenl = lenn 4219 lenn = min0(lenl,lfil) 4220 ! 4221 ! sort by quick-split 4222 ! 4223 call qsplit (w,jw,lenl,lenn) 4224 ! 4225 ! store L-part 4226 ! 4227 do 204 k=1, lenn 4228 if (ju0 .gt. iwk) goto 996 4229 alu(ju0) = w(k) 4230 jlu(ju0) = jw(k) 4231 ju0 = ju0+1 4232 204 continue 4233 ! 4234 ! save pointer to beginning of row ii of U 4235 ! Page 133 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4236 ju(ii) = ju0 4237 ! 4238 ! update U-matrix -- first apply dropping strategy 4239 ! 4240 lenn = 0 4241 do k=1, lenu-1 4242 if (abs(w(ii+k)) .gt. droptol*tnorm) then 4243 lenn = lenn+1 4244 w(ii+lenn) = w(ii+k) 4245 jw(ii+lenn) = jw(ii+k) 4246 endif 4247 enddo 4248 lenu = lenn+1 4249 lenn = min0(lenu,lfil) 4250 ! 4251 call qsplit (w(ii+1), jw(ii+1), lenu-1,lenn) 4252 ! 4253 ! copy 4254 ! 4255 t = abs(w(ii)) 4256 if (lenn + ju0 .gt. iwk) goto 997 4257 do 302 k=ii+1,ii+lenn-1 4258 jlu(ju0) = jw(k) 4259 alu(ju0) = w(k) 4260 t = t + abs(w(k) ) 4261 ju0 = ju0+1 4262 302 continue 4263 ! 4264 ! store inverse of diagonal element of u 4265 ! 4266 !2do check if it works ... after correction ... 4267 if (abs(w(ii)) .lt. tiny(1.d0)) w(ii) = (0.0001d0 + droptol)*tnorm 4268 ! 4269 alu(ii) = 1.0d0/ w(ii) 4270 ! 4271 ! update pointer to beginning of next row of U. 4272 ! 4273 jlu(ii+1) = ju0 4274 !----------------------------------------------------------------------- 4275 ! end main loop 4276 !----------------------------------------------------------------------- 4277 500 continue 4278 ierr = 0 4279 return 4280 ! 4281 ! incomprehensible error. Matrix must be wrong. 4282 ! 4283 995 ierr = -1 4284 return 4285 ! 4286 ! insufficient storage in L. 4287 ! 4288 996 ierr = -2 4289 return 4290 ! 4291 ! insufficient storage in U. 4292 ! Page 134 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4293 997 ierr = -3 4294 return 4295 ! 4296 ! illegal lfil entered. 4297 ! 4298 998 ierr = -4 4299 return 4300 ! 4301 ! zero row encountered 4302 ! 4303 999 ierr = -5 4304 return 4305 !----------------end-of-ilut-------------------------------------------- 4306 !----------------------------------------------------------------------- 4307 end ENTRY POINTS Name ilut_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 1 Label 4063 4061 150 Label 4111 4150,4207 151 Label 4127 4122 160 Label 4208 4112 170 Label 4105 4088 203 Label 4199 4154 204 Label 4232 4227 302 Label 4262 4257 308 Label 4214 4212 500 Label 4277 4067 501 Label 4075 4073 995 Label 4283 4167,4188 996 Label 4288 4228 997 Label 4293 4256 998 Label 4298 4051 999 Label 4303 4076 A Dummy 3961 R(8) 8 1 0 ARG,INOUT 4074,4090 ABS Func 4050 8 scalar 4074,4076,4150,4242,4255,4260,4267 ALU Dummy 3961 R(8) 8 1 0 ARG,INOUT 4149,4155,4229,4259,4269 DROPTOL Dummy 3961 R(8) 8 scalar ARG,INOUT 4150,4242,4267 FACT Local 4050 R(8) 8 scalar 4149,4150,4155,4205 I Local 4049 I(4) 4 scalar 4168,4169,4170,4171 IA Dummy 3961 I(4) 4 1 0 ARG,INOUT 4069,4070 IERR Dummy 3961 I(4) 4 scalar ARG,INOUT 4278,4283,4288,4293,4298,4303 II Local 4049 I(4) 4 scalar 4067,4069,4070,4084,4085,4086,4091 ,4096,4097,4100,4158,4168,4213,423 6,4242,4244,4245,4251,4255,4257,42 67,4269,4273 ILUT Subr 3961 Page 135 Source Listing ILUT 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References IWK Dummy 3961 I(4) 4 scalar ARG,INOUT 4228,4256 J Local 4049 I(4) 4 scalar 4061,4062,4088,4089,4090,4122,4123 ,4124,4125,4131,4133,4136,4156,415 7,4158,4169,4170,4189,4190 J1 Local 4049 I(4) 4 scalar 4069,4073,4078,4088 J2 Local 4049 I(4) 4 scalar 4070,4073,4078,4088 JA Dummy 3961 I(4) 4 1 0 ARG,INOUT 4089 JJ Local 4049 I(4) 4 scalar 4106,4111,4112,4117,4118,4122,4129 ,4131,4132,4135,4138,4139,4149 JLU Dummy 3961 I(4) 4 1 0 ARG,INOUT 4057,4154,4156,4230,4258,4273 JPOS Local 4049 I(4) 4 scalar 4100,4101,4102,4103,4157,4162,4176 ,4183,4196 JROW Local 4049 I(4) 4 scalar 4117,4123,4124,4135,4145,4149,4154 ,4206 JU Dummy 3961 I(4) 4 1 0 ARG,INOUT 4154,4236 JU0 Local 4049 I(4) 4 scalar 4056,4057,4228,4229,4230,4231,4236 ,4256,4258,4259,4261,4273 JW Dummy 3961 I(4) 4 1 0 ARG,INOUT 4062,4084,4086,4093,4095,4101,4103 ,4117,4123,4124,4131,4132,4133,413 5,4136,4145,4157,4169,4170,4189,41 90,4206,4213,4223,4230,4245,4251,4 258 K Local 4049 I(4) 4 scalar 4073,4074,4089,4091,4093,4095,4096 ,4101,4103,4118,4125,4129,4132,413 3,4136,4139,4140,4154,4155,4156,42 12,4213,4227,4229,4230,4241,4242,4 244,4245,4257,4258,4259,4260 LENL Local 4049 I(4) 4 scalar 4083,4092,4093,4094,4095,4112,4122 ,4187,4188,4189,4190,4191,4218,421 9,4223 LENN Local 4049 I(4) 4 scalar 4107,4204,4205,4206,4218,4219,4223 ,4227,4240,4243,4244,4245,4248,424 9,4251,4256,4257 LENU Local 4049 I(4) 4 scalar 4082,4099,4100,4166,4167,4168,4212 ,4241,4248,4249,4251 LFIL Dummy 3961 I(4) 4 scalar ARG,INOUT 4051,4219,4249 MIN0 Func 4219 scalar 4219,4249 N Dummy 3961 I(4) 4 scalar ARG,INOUT 3965,3966,4056,4061,4062,4067,4086 ,4095,4103,4135,4136,4145,4157,416 7,4170,4188,4190,4213 QSPLIT Subr 4223 4223,4251 REAL Func 4078 scalar 4078 S Local 4050 R(8) 8 scalar 4138,4140,4155,4171,4176,4191,4196 T Local 4050 R(8) 8 scalar 4090,4094,4097,4102,4255,4260 TINY Func 4076 scalar 4076,4267 TNORM Local 4050 R(8) 8 scalar 4072,4074,4076,4078,4242,4267 W Dummy 3961 R(8) 8 1 0 ARG,INOUT 4085,4094,4097,4102,4138,4139,4140 ,4149,4171,4176,4191,4196,4205,422 3,4229,4242,4244,4251,4255,4259,42 60,4267,4269 Page 136 Source Listing ILUT 2014-09-16 16:49 w3profsmd.f90 4308 !---------------------------------------------------------------------- 4309 ! subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ipoint1, ipoint2, ierr) 4310 subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) 4311 4312 implicit real*8 (a-h,o-z) 4313 real*8 a(*), alu(*) 4314 integer ja(*), ia(*), ju(*), jlu(*), iw(n) 4315 ! 4316 !----------------------------------------------------------------------- 4317 ju0 = n+2 4318 jlu(1) = ju0 !!! 4319 iw = 0 4320 do ii = 1, n 4321 js = ju0 4322 do j=ia(ii),ia(ii+1)-1 4323 jcol = ja(j) 4324 if (jcol .eq. ii) then 4325 alu(ii) = a(j) 4326 iw(jcol) = ii 4327 ju(ii) = ju0 !!! 4328 else 4329 alu(ju0) = a(j) 4330 jlu(ju0) = ja(j) 4331 iw(jcol) = ju0 4332 ju0 = ju0+1 4333 endif 4334 end do 4335 jlu(ii+1) = ju0 !!! 4336 jf = ju0-1 4337 jm = ju(ii)-1 4338 ! exit if diagonal element is reached. 4339 do j=js, jm 4340 jrow = jlu(j) 4341 tl = alu(j)*alu(jrow) 4342 alu(j) = tl 4343 ! perform linear combination 4344 do jj = ju(jrow), jlu(jrow+1)-1 4345 jw = iw(jlu(jj)) 4346 if (jw .ne. 0) then 4347 alu(jw) = alu(jw) - tl*alu(jj) 4348 ! write(*,*) ii, jw, jj 4349 end if 4350 end do 4351 end do 4352 ! invert and store diagonal element. 4353 if (abs(alu(ii)) .lt. tiny(1.)) goto 600 4354 alu(ii) = 1.0d0/alu(ii) 4355 ! reset pointer iw to zero 4356 iw(ii) = 0 4357 do i = js, jf 4358 iw(jlu(i)) = 0 4359 end do 4360 end do 4361 4362 ierr = 0 4363 return 4364 Page 137 Source Listing ILU0 2014-09-16 16:49 w3profsmd.f90 4365 ! zero pivot : 4366 600 ierr = ii 4367 return 4368 end ENTRY POINTS Name ilu0_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 600 Label 4366 4353 A Dummy 4310 R(8) 8 1 0 ARG,INOUT 4325,4329 ABS Func 4353 scalar 4353 ALU Dummy 4310 R(8) 8 1 0 ARG,INOUT 4325,4329,4341,4342,4347,4353,4354 I Local 4357 I(4) 4 scalar 4357,4358 IA Dummy 4310 I(4) 4 1 0 ARG,INOUT 4322 IERR Dummy 4310 I(4) 4 scalar ARG,INOUT 4362,4366 II Local 4320 I(4) 4 scalar 4320,4322,4324,4325,4326,4327,4335 ,4337,4353,4354,4356,4366 ILU0 Subr 4310 IW Dummy 4310 I(4) 4 1 0 ARG,INOUT 4319,4326,4331,4345,4356,4358 J Local 4322 I(4) 4 scalar 4322,4323,4325,4329,4330,4339,4340 ,4341,4342 JA Dummy 4310 I(4) 4 1 0 ARG,INOUT 4323,4330 JCOL Local 4323 I(4) 4 scalar 4323,4324,4326,4331 JF Local 4336 I(4) 4 scalar 4336,4357 JJ Local 4344 I(4) 4 scalar 4344,4345,4347 JLU Dummy 4310 I(4) 4 1 0 ARG,INOUT 4318,4330,4335,4340,4344,4345,4358 JM Local 4337 I(4) 4 scalar 4337,4339 JROW Local 4340 I(4) 4 scalar 4340,4341,4344 JS Local 4321 I(4) 4 scalar 4321,4339,4357 JU Dummy 4310 I(4) 4 1 0 ARG,INOUT 4327,4337,4344 JU0 Local 4317 I(4) 4 scalar 4317,4318,4321,4327,4329,4330,4331 ,4332,4335,4336 JW Local 4345 I(4) 4 scalar 4345,4346,4347 N Dummy 4310 I(4) 4 scalar ARG,INOUT 4314,4317,4320 TINY Func 4353 scalar 4353 TL Local 4341 R(8) 8 scalar 4341,4342,4347 Page 138 Source Listing ILU0 2014-09-16 16:49 w3profsmd.f90 4369 !----------------------------------------------------------------------- 4370 ! subroutine pgmres(n, im, rhs, sol, eps, maxits, ierr) 4371 ! subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, ierr) 4372 subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, nnz, ia, ja, alu, jlu, ju, vv, ierr) 4373 !----------------------------------------------------------------------- 4374 ! use datapool, only : nnz, ia, ja, alu, jlu, ju, vv, aspar!, rhs, sol 4375 implicit none 4376 4377 integer :: n, im, maxits, ierr, nnz 4378 4379 integer :: ja(nnz), ia(n+1) 4380 integer :: jlu(nnz+1), ju(n) 4381 real*8 :: vv(n,im+1), alu(nnz+1) 4382 real*8 :: aspar(nnz) 4383 4384 real*8 :: rhs(*), sol(*) 4385 4386 real*8 :: eps 4387 real*8 :: eps1, epsmac, gam, t, ddot, dnrm2, ro, tl 4388 4389 integer :: i,i1,j,jj,k,k1,iii,ii,ju0 4390 integer :: its,jrow,jcol,jf,jm,js,jw 4391 4392 real*8 :: hh(im+1,im), c(im), s(im), rs(im+1) 4393 real*8 :: iw(n) 4394 4395 logical :: lblas = .false. ! use sparskit matvec and external blas libs (true), don't use them (false) 4396 logical :: lilu = .true. ! use simple ilu preconditioner 4397 4398 data epsmac/1.d-16/ 4399 4400 ! ilu0 preconditioner 4401 4402 if (lilu) then 4403 ju0 = n+2 4404 jlu(1) = ju0 !!! 4405 iw = 0 4406 do ii = 1, n 4407 js = ju0 4408 do j=ia(ii),ia(ii+1)-1 4409 jcol = ja(j) 4410 if (jcol .eq. ii) then 4411 alu(ii) = aspar(j) 4412 iw(jcol) = ii 4413 ju(ii) = ju0 !!! 4414 else 4415 alu(ju0) = aspar(j) 4416 jlu(ju0) = ja(j) 4417 iw(jcol) = ju0 4418 ju0 = ju0+1 4419 endif 4420 end do 4421 jlu(ii+1) = ju0 !!! 4422 jf = ju0-1 4423 jm = ju(ii)-1 4424 ! exit if diagonal element is reached. 4425 do j=js, jm Page 139 Source Listing PGMRES 2014-09-16 16:49 w3profsmd.f90 4426 jrow = jlu(j) 4427 tl = alu(j)*alu(jrow) 4428 alu(j) = tl 4429 ! perform linear combination 4430 do jj = ju(jrow), jlu(jrow+1)-1 4431 jw = int(iw(jlu(jj))) 4432 if (jw .ne. 0) then 4433 alu(jw) = alu(jw) - tl*alu(jj) 4434 ! write(*,*) ii, jw, jj 4435 end if 4436 end do 4437 end do 4438 ! invert and store diagonal element. 4439 if (abs(alu(ii)) .lt. epsmac) then 4440 write (*,*) 'zero pivot' 4441 stop 4442 end if 4443 alu(ii) = 1.0d0/alu(ii) 4444 ! reset pointer iw to zero 4445 iw(ii) = 0 4446 do i = js, jf 4447 iw(jlu(i)) = 0 4448 end do 4449 end do 4450 ! end preconditioner 4451 end if 4452 !------------------------------------------------------------- 4453 its = 0 4454 ! outer loop starts here.. 4455 if (lblas) then 4456 call amux (n, sol, vv, aspar, ja, ia) 4457 else 4458 do iii = 1, n 4459 t = 0.0d0 4460 do k = ia(iii), ia(iii+1)-1 4461 t = t + aspar(k) * sol(ja(k)) 4462 end do 4463 vv(iii,1) = t 4464 end do 4465 end if 4466 do j=1,n 4467 vv(j,1) = rhs(j) - vv(j,1) 4468 end do 4469 20 if (lblas) then 4470 ro = dnrm2(n, vv) 4471 else 4472 ro = sqrt(sum(vv(:,1)*vv(:,1))) 4473 end if 4474 if (abs(ro) .lt. epsmac) goto 999 4475 t = 1.0d0 / ro 4476 do j=1, n 4477 vv(j,1) = vv(j,1)*t 4478 end do 4479 if (its .eq. 0) eps1=eps*ro 4480 ! initialize 1-st term of rhs of hessenberg system.. 4481 rs(1) = ro 4482 i = 0 Page 140 Source Listing PGMRES 2014-09-16 16:49 w3profsmd.f90 4483 4 i=i+1 4484 its = its + 1 4485 i1 = i + 1 4486 if (lblas) then 4487 call lusol (n, vv(1,i), rhs, alu, jlu, ju) 4488 call amux (n, rhs, vv(1,i1), aspar, ja, ia) 4489 else 4490 do iii = 1, n !- lusol 4491 rhs(iii) = vv(iii,i) 4492 do k=jlu(iii),ju(iii)-1 4493 rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) 4494 end do 4495 end do 4496 do iii = n, 1, -1 4497 do k=ju(iii),jlu(iii+1)-1 4498 rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) 4499 end do 4500 rhs(iii) = alu(iii)*rhs(iii) 4501 end do 4502 do iii = 1, n !- amux 4503 t = 0.0d0 4504 do k = ia(iii), ia(iii+1)-1 4505 t = t + aspar(k) * rhs(ja(k)) 4506 end do 4507 vv(iii,i1) = t 4508 end do 4509 end if 4510 ! modified gram - schmidt... 4511 if (lblas) then 4512 do j=1, i 4513 t = ddot(n, vv(1,j),vv(1,i1)) 4514 hh(j,i) = t 4515 call daxpy(n, -t, vv(1,j), 1, vv(1,i1), 1) 4516 t = dnrm2(n, vv(1,i1)) 4517 end do 4518 else 4519 do j=1, i 4520 t = 0.d0 4521 do iii = 1,n 4522 t = t + vv(iii,j)*vv(iii,i1) 4523 end do 4524 hh(j,i) = t 4525 vv(:,i1) = vv(:,i1) - t * vv(:,j) 4526 t = sqrt(sum(vv(:,i1)*vv(:,i1))) 4527 end do 4528 end if 4529 hh(i1,i) = t 4530 if ( abs(t) .lt. epsmac) goto 58 4531 t = 1.0d0/t 4532 do k=1,n 4533 vv(k,i1) = vv(k,i1)*t 4534 end do 4535 ! done with modified gram schimd and arnoldi step.. now update factorization of hh 4536 58 if (i .eq. 1) goto 121 4537 do k=2,i 4538 k1 = k-1 4539 t = hh(k1,i) Page 141 Source Listing PGMRES 2014-09-16 16:49 w3profsmd.f90 4540 hh(k1,i) = c(k1)*t + s(k1)*hh(k,i) 4541 hh(k,i) = -s(k1)*t + c(k1)*hh(k,i) 4542 end do 4543 121 gam = sqrt(hh(i,i)**2 + hh(i1,i)**2) 4544 if (abs(gam) .lt. epsmac) gam = epsmac 4545 ! get next plane rotation 4546 c(i) = hh(i,i)/gam 4547 s(i) = hh(i1,i)/gam 4548 rs(i1) = -s(i)*rs(i) 4549 rs(i) = c(i)*rs(i) 4550 ! detrermine residual norm and test for convergence- 4551 hh(i,i) = c(i)*hh(i,i) + s(i)*hh(i1,i) 4552 ro = abs(rs(i1)) 4553 if (i .lt. im .and. (ro .gt. eps1)) goto 4 4554 ! now compute solution. first solve upper triangular system. 4555 rs(i) = rs(i)/hh(i,i) 4556 do ii=2,i 4557 k=i-ii+1 4558 k1 = k+1 4559 t=rs(k) 4560 do j=k1,i 4561 t = t-hh(k,j)*rs(j) 4562 end do 4563 rs(k) = t/hh(k,k) 4564 end do 4565 ! form linear combination of v(*,i)'s to get solution 4566 t = rs(1) 4567 do k=1, n 4568 rhs(k) = vv(k,1)*t 4569 end do 4570 do j = 2, i 4571 t = rs(j) 4572 do k=1, n 4573 rhs(k) = rhs(k)+t*vv(k,j) 4574 end do 4575 end do 4576 ! call preconditioner. 4577 if (lblas) then 4578 call lusol (n, rhs, rhs, alu, jlu, ju) 4579 else 4580 do iii = 1, n 4581 do k=jlu(iii),ju(iii)-1 4582 rhs(iii) = rhs(iii) - alu(k)* rhs(jlu(k)) 4583 end do 4584 end do 4585 do iii = n, 1, -1 4586 do k=ju(iii),jlu(iii+1)-1 4587 rhs(iii) = rhs(iii) - alu(k)*rhs(jlu(k)) 4588 end do 4589 rhs(iii) = alu(iii)*rhs(iii) 4590 end do 4591 end if 4592 do k=1, n 4593 sol(k) = sol(k) + rhs(k) 4594 end do 4595 ! restart outer loop when necessary 4596 if (ro .le. eps1) goto 990 Page 142 Source Listing PGMRES 2014-09-16 16:49 w3profsmd.f90 4597 if (its .ge. maxits) goto 991 4598 ! else compute residual vector and continue.. 4599 do j=1,i 4600 jj = i1-j+1 4601 rs(jj-1) = -s(jj-1)*rs(jj) 4602 rs(jj) = c(jj-1)*rs(jj) 4603 end do 4604 do j=1,i1 4605 t = rs(j) 4606 if (j .eq. 1) t = t-1.0d0 4607 if (lblas) then 4608 call daxpy (n, t, vv(1,j), 1, vv, 1) 4609 else 4610 vv(:,j) = vv(:,j) + t * vv(:,1) 4611 end if 4612 end do 4613 ! 199 format(' its =', i4, ' res. norm =', d20.6) 4614 ! restart outer loop. 4615 goto 20 4616 990 ierr = 0 4617 return 4618 991 ierr = 1 4619 return 4620 999 continue 4621 ierr = -1 4622 return 4623 !--------------------------------------------------------------------- 4624 end Page 143 Source Listing PGMRES 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name pgmres_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 121 Label 4543 4536 20 Label 4469 4615 4 Label 4483 4553 58 Label 4536 4530 990 Label 4616 4596 991 Label 4618 4597 999 Label 4620 4474 ABS Func 4439 scalar 4439,4474,4530,4544,4552 ALU Dummy 4372 R(8) 8 1 0 ARG,INOUT 4411,4415,4427,4428,4433,4439,4443 ,4487,4493,4498,4500,4578,4582,458 7,4589 AMUX Subr 4456 4456,4488 ASPAR Dummy 4372 R(8) 8 1 0 ARG,INOUT 4411,4415,4456,4461,4488,4505 C Local 4392 R(8) 8 1 0 4540,4541,4546,4549,4551,4602 DAXPY Subr 4515 4515,4608 DDOT Func 4387 R(8) 8 scalar 4513 DNRM2 Func 4387 R(8) 8 scalar 4470,4516 EPS Dummy 4372 R(8) 8 scalar ARG,INOUT 4479 EPS1 Local 4387 R(8) 8 scalar 4479,4553,4596 EPSMAC Local 4387 R(8) 8 scalar 4398,4439,4474,4530,4544 GAM Local 4387 R(8) 8 scalar 4543,4544,4546,4547 HH Local 4392 R(8) 8 2 0 4514,4524,4529,4539,4540,4541,4543 ,4546,4547,4551,4555,4561,4563 I Local 4389 I(4) 4 scalar 4446,4447,4482,4483,4485,4487,4491 ,4512,4514,4519,4524,4529,4536,453 7,4539,4540,4541,4543,4546,4547,45 48,4549,4551,4553,4555,4556,4557,4 560,4570,4599 I1 Local 4389 I(4) 4 scalar 4485,4488,4507,4513,4515,4516,4522 ,4525,4526,4529,4533,4543,4547,454 8,4551,4552,4600,4604 IA Dummy 4372 I(4) 4 1 0 ARG,INOUT 4408,4456,4460,4488,4504 IERR Dummy 4372 I(4) 4 scalar ARG,INOUT 4616,4618,4621 II Local 4389 I(4) 4 scalar 4406,4408,4410,4411,4412,4413,4421 ,4423,4439,4443,4445,4556,4557 III Local 4389 I(4) 4 scalar 4458,4460,4463,4490,4491,4492,4493 ,4496,4497,4498,4500,4502,4504,450 7,4521,4522,4580,4581,4582,4585,45 86,4587,4589 IM Dummy 4372 I(4) 4 scalar ARG,INOUT 4381,4392,4553 INT Func 4431 scalar 4431 ITS Local 4390 I(4) 4 scalar 4453,4479,4484,4597 IW Local 4393 R(8) 8 1 0 4405,4412,4417,4431,4445,4447 J Local 4389 I(4) 4 scalar 4408,4409,4411,4415,4416,4425,4426 Page 144 Source Listing PGMRES 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References ,4427,4428,4466,4467,4476,4477,451 2,4513,4514,4515,4519,4522,4524,45 25,4560,4561,4570,4571,4573,4599,4 600,4604,4605,4606,4608,4610 JA Dummy 4372 I(4) 4 1 0 ARG,INOUT 4409,4416,4456,4461,4488,4505 JCOL Local 4390 I(4) 4 scalar 4409,4410,4412,4417 JF Local 4390 I(4) 4 scalar 4422,4446 JJ Local 4389 I(4) 4 scalar 4430,4431,4433,4600,4601,4602 JLU Dummy 4372 I(4) 4 1 0 ARG,INOUT 4404,4416,4421,4426,4430,4431,4447 ,4487,4492,4493,4497,4498,4578,458 1,4582,4586,4587 JM Local 4390 I(4) 4 scalar 4423,4425 JROW Local 4390 I(4) 4 scalar 4426,4427,4430 JS Local 4390 I(4) 4 scalar 4407,4425,4446 JU Dummy 4372 I(4) 4 1 0 ARG,INOUT 4413,4423,4430,4487,4492,4497,4578 ,4581,4586 JU0 Local 4389 I(4) 4 scalar 4403,4404,4407,4413,4415,4416,4417 ,4418,4421,4422 JW Local 4390 I(4) 4 scalar 4431,4432,4433 K Local 4389 I(4) 4 scalar 4460,4461,4492,4493,4497,4498,4504 ,4505,4532,4533,4537,4538,4540,454 1,4557,4558,4559,4561,4563,4567,45 68,4572,4573,4581,4582,4586,4587,4 592,4593 K1 Local 4389 I(4) 4 scalar 4538,4539,4540,4541,4558,4560 LBLAS Local 4395 L(4) 4 scalar 4395,4455,4469,4486,4511,4577,4607 LILU Local 4396 L(4) 4 scalar 4396,4402 LUSOL Subr 4487 4487,4578 MAXITS Dummy 4372 I(4) 4 scalar ARG,INOUT 4597 N Dummy 4372 I(4) 4 scalar ARG,INOUT 4379,4380,4381,4393,4403,4406,4456 ,4458,4466,4470,4476,4487,4488,449 0,4496,4502,4513,4515,4516,4521,45 32,4567,4572,4578,4580,4585,4592,4 608 NNZ Dummy 4372 I(4) 4 scalar ARG,INOUT 4379,4380,4381,4382 PGMRES Subr 4372 RHS Dummy 4372 R(8) 8 1 0 ARG,INOUT 4467,4487,4488,4491,4493,4498,4500 ,4505,4568,4573,4578,4582,4587,458 9,4593 RO Local 4387 R(8) 8 scalar 4470,4472,4474,4475,4479,4481,4552 ,4553,4596 RS Local 4392 R(8) 8 1 0 4481,4548,4549,4552,4555,4559,4561 ,4563,4566,4571,4601,4602,4605 S Local 4392 R(8) 8 1 0 4540,4541,4547,4548,4551,4601 SOL Dummy 4372 R(8) 8 1 0 ARG,INOUT 4456,4461,4593 SQRT Func 4472 scalar 4472,4526,4543 SUM Func 4472 scalar 4472,4526 T Local 4387 R(8) 8 scalar 4459,4461,4463,4475,4477,4503,4505 ,4507,4513,4514,4515,4516,4520,452 2,4524,4525,4526,4529,4530,4531,45 33,4539,4540,4541,4559,4561,4563,4 566,4568,4571,4573,4605,4606,4608, 4610 TL Local 4387 R(8) 8 scalar 4427,4428,4433 VV Dummy 4372 R(8) 8 2 0 ARG,INOUT 4456,4463,4467,4470,4472,4477,4487 Page 145 Source Listing PGMRES 2014-09-16 16:49 Symbol Table w3profsmd.f90 Name Object Declared Type Bytes Dimen Elements Attributes References ,4488,4491,4507,4513,4515,4516,452 2,4525,4526,4533,4568,4573,4608,46 10 Page 146 Source Listing PGMRES 2014-09-16 16:49 w3profsmd.f90 4625 !----------------------------------------------------------------------- 4626 4627 !----------------------------------------------------------------------- 4628 !----------------------------------------------------------------------- 4629 ! subroutine from blas1.f90 4630 !----------------------------------------------------------------------- 4631 DOUBLE PRECISION FUNCTION DNRM2(N,X) 4632 ! .. Scalar Arguments .. 4633 INTEGER N 4634 ! .. 4635 ! .. Array Arguments .. 4636 DOUBLE PRECISION X(*) 4637 ! .. 4638 ! 4639 ! Purpose 4640 ! ======= 4641 ! 4642 ! DNRM2 returns the euclidean norm of a vector via the function 4643 ! name, so that 4644 ! 4645 ! DNRM2 := sqrt( x'*x ) 4646 ! 4647 ! Further Details 4648 ! =============== 4649 ! 4650 ! -- This version written on 25-October-1982. 4651 ! Modified on 14-October-1993 to inline the call to DLASSQ. 4652 ! Sven Hammarling, Nag Ltd. 4653 ! 4654 ! ===================================================================== 4655 ! 4656 ! .. Parameters .. 4657 DOUBLE PRECISION ONE,ZERO 4658 PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) 4659 ! .. 4660 ! .. Local Scalars .. 4661 DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ 4662 INTEGER IX 4663 ! .. 4664 ! .. Intrinsic Functions .. 4665 INTRINSIC ABS,SQRT 4666 ! .. 4667 IF (N.LT.1 ) THEN 4668 NORM = ZERO 4669 ELSE IF (N.EQ.1) THEN 4670 NORM = ABS(X(1)) 4671 ELSE 4672 SCALE = ZERO 4673 SSQ = ONE 4674 ! The following loop is equivalent to this call to the LAPACK 4675 ! auxiliary routine: 4676 ! CALL DLASSQ( N, X, SCALE, SSQ ) 4677 ! 4678 DO 10 IX = 1,1 + (N-1) 4679 IF (X(IX).NE.ZERO) THEN 4680 ABSXI = ABS(X(IX)) 4681 IF (SCALE.LT.ABSXI) THEN Page 147 Source Listing DNRM2 2014-09-16 16:49 w3profsmd.f90 4682 SSQ = ONE + SSQ* (SCALE/ABSXI)**2 4683 SCALE = ABSXI 4684 ELSE 4685 SSQ = SSQ + (ABSXI/SCALE)**2 4686 END IF 4687 END IF 4688 10 CONTINUE 4689 NORM = SCALE*SQRT(SSQ) 4690 END IF 4691 ! 4692 DNRM2 = NORM 4693 RETURN 4694 ! 4695 ! End of DNRM2. 4696 ! 4697 END ENTRY POINTS Name dnrm2_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 4688 4678 ABS Func 4665 scalar 4670,4680 ABSXI Local 4661 R(8) 8 scalar 4680,4681,4682,4683,4685 DNRM2 Func 4631 R(8) 8 scalar 4692 DNRM2@0 Local 4631 R(8) 8 scalar IX Local 4662 I(4) 4 scalar 4678,4679,4680 N Dummy 4631 I(4) 4 scalar ARG,INOUT 4667,4669,4678 NORM Local 4661 R(8) 8 scalar 4668,4670,4689,4692 ONE Param 4657 R(8) 8 scalar 4673,4682 SCALE Local 4661 R(8) 8 scalar 4672,4681,4682,4683,4685,4689 SQRT Func 4665 scalar 4689 SSQ Local 4661 R(8) 8 scalar 4673,4682,4685,4689 X Dummy 4631 R(8) 8 1 0 ARG,INOUT 4670,4679,4680 ZERO Param 4657 R(8) 8 scalar 4668,4672,4679 Page 148 Source Listing DNRM2 2014-09-16 16:49 w3profsmd.f90 4698 4699 !----------------------------------------------------------------------- 4700 SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ ) 4701 ! 4702 ! -- LAPACK auxiliary routine (version 3.1) -- 4703 ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 4704 ! November 2006 4705 INTEGER N 4706 DOUBLE PRECISION SCALE, SUMSQ 4707 DOUBLE PRECISION X( * ) 4708 ! 4709 ! DLASSQ returns the values scl and smsq such that 4710 ! 4711 ! ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, 4712 ! 4713 ! where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is 4714 ! assumed to be non-negative and scl returns the value 4715 ! 4716 ! scl = max( scale, abs( x( i ) ) ). 4717 ! 4718 ! SCALE (input/output) DOUBLE PRECISION 4719 ! On entry, the value scale in the equation above. 4720 ! On exit, SCALE is overwritten with scl , the scaling factor 4721 ! for the sum of squares. 4722 DOUBLE PRECISION ZERO 4723 PARAMETER ( ZERO = 0.0D+0 ) 4724 INTEGER IX 4725 DOUBLE PRECISION ABSXI 4726 INTRINSIC ABS 4727 ! 4728 IF( N.GT.0 ) THEN 4729 DO IX = 1, 1 + ( N-1 ) 4730 IF( X( IX ).NE.ZERO ) THEN 4731 ABSXI = ABS( X( IX ) ) 4732 IF( SCALE.LT.ABSXI ) THEN 4733 SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 4734 SCALE = ABSXI 4735 ELSE 4736 SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 4737 END IF 4738 END IF 4739 END DO 4740 END IF 4741 RETURN 4742 END Page 149 Source Listing DLASSQ 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name dlassq_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References ABS Func 4726 scalar 4731 ABSXI Local 4725 R(8) 8 scalar 4731,4732,4733,4734,4736 DLASSQ Subr 4700 IX Local 4724 I(4) 4 scalar 4729,4730,4731 N Dummy 4700 I(4) 4 scalar ARG,INOUT 4728,4729 SCALE Dummy 4700 R(8) 8 scalar ARG,INOUT 4732,4733,4734,4736 SUMSQ Dummy 4700 R(8) 8 scalar ARG,INOUT 4733,4736 X Dummy 4700 R(8) 8 1 0 ARG,INOUT 4730,4731 ZERO Param 4722 R(8) 8 scalar 4730 Page 150 Source Listing DLASSQ 2014-09-16 16:49 w3profsmd.f90 4743 4744 !------------------------------------------------------------------------- 4745 double precision function ddot(n,dx,dy) 4746 ! 4747 ! forms the dot product of two vectors. 4748 ! uses unrolled loops for increments equal to one. 4749 ! jack dongarra, linpack, 3/11/78. 4750 ! 4751 double precision dx(*),dy(*),dtemp 4752 integer i,ix,iy,m,mp1,n 4753 ! 4754 ddot = 0.0d0 4755 dtemp = 0.0d0 4756 if(n.le.0)return 4757 4758 20 m = mod(n,5) 4759 if( m .eq. 0 ) go to 40 4760 do 30 i = 1,m 4761 dtemp = dtemp + dx(i)*dy(i) 4762 30 continue 4763 if( n .lt. 5 ) go to 60 4764 40 mp1 = m + 1 4765 do 50 i = mp1,n,5 4766 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + & 4767 & dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) 4768 50 continue 4769 60 ddot = dtemp 4770 return 4771 end Page 151 Source Listing DDOT 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name ddot_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 20 Label 4758 30 Label 4762 4760 40 Label 4764 4759 50 Label 4768 4765 60 Label 4769 4763 DDOT Func 4745 R(8) 8 scalar 4754,4769 DDOT@0 Local 4745 R(8) 8 scalar DTEMP Local 4751 R(8) 8 scalar 4755,4761,4766,4769 DX Dummy 4745 R(8) 8 1 0 ARG,INOUT 4761,4766,4767 DY Dummy 4745 R(8) 8 1 0 ARG,INOUT 4761,4766,4767 I Local 4752 I(4) 4 scalar 4760,4761,4765,4766,4767 IX Local 4752 I(4) 4 scalar IY Local 4752 I(4) 4 scalar M Local 4752 I(4) 4 scalar 4758,4759,4760,4764 MOD Func 4758 scalar 4758 MP1 Local 4752 I(4) 4 scalar 4764,4765 N Dummy 4745 I(4) 4 scalar ARG,INOUT 4756,4758,4763,4765 Page 152 Source Listing DDOT 2014-09-16 16:49 w3profsmd.f90 4772 !---------------------------------------------------------------------- 4773 subroutine daxpy(n,da,dx,incx,dy,incy) 4774 ! 4775 ! constant times a vector plus a vector. 4776 ! uses unrolled loops for increments equal to one. 4777 ! jack dongarra, linpack, 3/11/78. 4778 ! 4779 double precision dx(1),dy(1),da 4780 integer i,incx,incy,ix,iy,m,mp1,n 4781 ! 4782 if(n.le.0)return 4783 if (abs(da) .lt. tiny(1.d0)) return 4784 if(incx.eq.1.and.incy.eq.1)go to 20 4785 ! 4786 ! code for unequal increments or equal increments 4787 ! not equal to 1 4788 ! 4789 ix = 1 4790 iy = 1 4791 if(incx.lt.0)ix = (-n+1)*incx + 1 4792 if(incy.lt.0)iy = (-n+1)*incy + 1 4793 do 10 i = 1,n 4794 dy(iy) = dy(iy) + da*dx(ix) 4795 ix = ix + incx 4796 iy = iy + incy 4797 10 continue 4798 return 4799 ! 4800 ! code for both increments equal to 1 4801 ! 4802 ! clean-up loop 4803 ! 4804 20 m = mod(n,4) 4805 if( m .eq. 0 ) go to 40 4806 do 30 i = 1,m 4807 dy(i) = dy(i) + da*dx(i) 4808 30 continue 4809 if( n .lt. 4 ) return 4810 40 mp1 = m + 1 4811 do 50 i = mp1,n,4 4812 dy(i) = dy(i) + da*dx(i) 4813 dy(i + 1) = dy(i + 1) + da*dx(i + 1) 4814 dy(i + 2) = dy(i + 2) + da*dx(i + 2) 4815 dy(i + 3) = dy(i + 3) + da*dx(i + 3) 4816 50 continue 4817 return 4818 end Page 153 Source Listing DAXPY 2014-09-16 16:49 Entry Points w3profsmd.f90 ENTRY POINTS Name daxpy_ SYMBOL CROSS REFERENCE Name Object Declared Type Bytes Dimen Elements Attributes References 10 Label 4797 4793 20 Label 4804 4784 30 Label 4808 4806 40 Label 4810 4805 50 Label 4816 4811 ABS Func 4783 scalar 4783 DA Dummy 4773 R(8) 8 scalar ARG,INOUT 4783,4794,4807,4812,4813,4814,4815 DAXPY Subr 4773 DX Dummy 4773 R(8) 8 1 1 ARG,INOUT 4794,4807,4812,4813,4814,4815 DY Dummy 4773 R(8) 8 1 1 ARG,INOUT 4794,4807,4812,4813,4814,4815 I Local 4780 I(4) 4 scalar 4793,4806,4807,4811,4812,4813,4814 ,4815 INCX Dummy 4773 I(4) 4 scalar ARG,INOUT 4784,4791,4795 INCY Dummy 4773 I(4) 4 scalar ARG,INOUT 4784,4792,4796 IX Local 4780 I(4) 4 scalar 4789,4791,4794,4795 IY Local 4780 I(4) 4 scalar 4790,4792,4794,4796 M Local 4780 I(4) 4 scalar 4804,4805,4806,4810 MOD Func 4804 scalar 4804 MP1 Local 4780 I(4) 4 scalar 4810,4811 N Dummy 4773 I(4) 4 scalar ARG,INOUT 4782,4791,4792,4793,4804,4809,4811 TINY Func 4783 scalar 4783 Page 154 Source Listing DAXPY 2014-09-16 16:49 Subprograms/Common Blocks w3profsmd.f90 SUBPROGRAMS/COMMON BLOCKS Name Object Declared Type Bytes Dimen Elements Attributes References AMUX Subr 2954 AMUXD Subr 3189 AMUXE Subr 3140 AMUXJ Subr 3241 AMUXMS Subr 3000 ATMUX Subr 3042 ATMUXR Subr 3091 BCGSTAB Subr 1894 BISINIT Subr 2727 BRKDN Func 2691 L(4) 4 scalar 2703,2707,2713,2717,2720 DAXPY Subr 4773 DDOT Func 4745 R(8) 8 scalar 4754,4769 DLASSQ Subr 4700 DNRM2 Func 4631 R(8) 8 scalar 4692 GIVENS Subr 2557 GMRES Subr 2169 ILU0 Subr 4310 ILUT Subr 3961 IMPLU Subr 2476 LDSOL Subr 3392 LDSOLC Subr 3479 LDSOLL Subr 3526 LSOL Subr 3349 LSOLC Subr 3435 LUSOL Subr 3755 LUTSOL Subr 3783 MGSRO Subr 2798 PGMRES Subr 4372 QSPLIT Subr 3820 RUNRC Subr 3882 STOPBIS Func 2599 L(4) 4 scalar 2609,2611,2615,2617,2646,2649 TIDYCG Subr 2657 UDSOL Subr 3621 UDSOLC Subr 3709 UPPDIR Subr 2518 USOL Subr 3578 USOLC Subr 3665 VBRMV Subr 3295 W3CFLUG Subr 253 W3PROFSMD Module 2 W3XYPFSFCT2 Subr 1225 233 W3XYPFSN2 Subr 431 229 W3XYPFSNIMP Subr 914 235 W3XYPFSPSI2 Subr 670 231 W3XYPUG Subr 58 COMPILER OPTIONS BEING USED -align nocommons -align nodcommons -align noqcommons -align records -align nosequence -align norec1byte Page 155 Source Listing DAXPY 2014-09-16 16:49 w3profsmd.f90 -align norec2byte -align norec4byte -align norec8byte -align norec16byte -altparam -assume accuracy_sensitive -assume nobscc -assume nobuffered_io -assume byterecl -assume cc_omp -assume nocstring -assume nodummy_aliases -assume nofpe_summary -assume noieee_fpe_flags -assume nominus0 -assume noold_boz -assume old_unit_star -assume old_ldout_format -assume noold_logical_ldio -assume old_maxminloc -assume old_xor -assume protect_constants -assume noprotect_parens -assume split_common -assume source_include -assume nostd_intent_in -assume nostd_mod_proc_name -assume norealloc_lhs -assume underscore -assume no2underscores -auto no -auto_scalar no -bintext -ccdefault default -check noargs -check noarg_temp_created -check nobounds -check noformat -check nooutput_conversion -check nooverflow -check nopointers -check power -check noshape -check nounderflow -check nouninitialized -coarray-num-procs 0 no -coarray-config-file -convert big_endian -cross_reference -D __INTEL_COMPILER=1210 -D __unix__ -D __unix -D __linux__ -D __linux -D __gnu_linux__ -D unix -D linux -D __ELF__ -D __x86_64 -D __x86_64__ -D _MT -D __INTEL_COMPILER_BUILD_DATE=20120612 -D _OPENMP=201107 -D __pentium4 -D __pentium4__ -D __tune_pentium4__ -D __SSE2__ -D __SSE3__ -D __SSSE3__ -D __SSE4_1__ -D __SSE4_2__ -D __SSE__ -D __MMX__ -D __AVX__ -double_size 64 no -d_lines no -Qdyncom -error_limit 30 no -f66 no -f77rtl no -fast -fpscomp nofilesfromcmd -fpscomp nogeneral -fpscomp noioformat -fpscomp noldio_spacing -fpscomp nologicals no -fpconstant -fpe3 -fprm nearest no -ftz -fp_model noprecise -fp_model fast -fp_model nostrict -fp_model nosource -fp_model nodouble -fp_model noextended -fp_model novery_fast -fp_model noexcept -fp_model nono_except -heap_arrays 0 no -threadprivate_compat -free -g0 -iface nomixed_str_len_arg -iface nono_mixed_str_len_arg no -intconstant -integer_size 32 no -mixed_str_len_arg no -module -names lowercase no -noinclude -openmp -O2 no -pad_source Page 156 Source Listing DAXPY 2014-09-16 16:49 w3profsmd.f90 -real_size 32 no -recursive -reentrancy threaded no -sharable_localsaves -vec=simd -show noinclude -show map -show options no -syntax_only no -threadcom no -U no -vms -w noall -w nonone -w alignments -w noargument_checking -w nodeclarations -w general -w noignore_bounds -w noignore_loc -w nointerfaces -w notruncated_source -w uncalled -w uninitialized -w nounused -w usage -includepath : /usrx/local/intel/composerxe/tbb/include/,/usr/include/,./,/usrx/local/intel/impi/4.0.3.008/intel64/include/, /usrx/local/intel/impi/4.0.3.008/intel64/include/,/usrx/local/intel/composerxe/mkl/include/,/usrx/local/intel/composerxe/tbb/include/, /gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/intel64/,/gpfs/gp1/usrx/local/intel/composer_xe_2011_sp1.11.339/compiler/include/, /usr/local/include/,/usr/lib/gcc/x86_64-redhat-linux/4.4.7/include/,/usr/include/,/usr/include/ -list filename : w3profsmd.lst -o filename : none COMPILER: Intel(R) Fortran 12.1-2100