1 2 SUBROUTINE PSIDE2_TOX(DVAL,DVALD) 3 !*********************************************************************** 4 ! PSIDE2_TOX Module of the AMS/EPA Regulatory Model - AERMOD 5 ! 6 ! Special version of PSIDE2_TOX optimized for TOXICS applications. 7 ! Utilizes Romberg Integration (QATR3) or Gaussian Quadrature (QG2) 8 ! depending on the source receptor geometry. 9 ! 10 ! PURPOSE: Integrates Over Segments For Which ABS(VN) > VNTEST 11 ! Eliminates Overlap of Segments And Useless Integration 12 ! 13 ! PROGRAMMER: Jeff Wang, Roger Brode 14 ! Adapted From Codes By Richard Strelitz, CSC 15 ! 16 ! DATE: July 7, 1993 17 ! 18 ! INPUTS: Number of The Original Segments 19 ! End Points Array of The Segments 20 ! 21 ! OUTPUT: The Correction of The Results From PSIDE 22 ! 23 ! CALLED FROM: AREAIN 24 !*********************************************************************** 25 26 ! Variable Declarations 27 USE MAIN1 28 IMPLICIT NONE 29 CHARACTER MODNAM*12 30 31 SAVE 32 33 !---- Set convergence criteria for call to QATR3: 34 ! NDIM = maximum number of integration steps 35 ! IMIN = minimum number of integration steps 36 ! EPSR = relative error tolerance for integral 37 ! EPST = minimum value threshold for integral 38 !---- 39 INTEGER , PARAMETER :: NDIM = 10 , IMIN = 4 40 REAL , PARAMETER :: EPSR = 2.0E-2 , EPST = 1.0E-5 41 42 !---- Set distance factor for switching to Gaussian Quadrature, QG_FACT 43 ! If Xmax - Xmin is .LT. QG_FACT*Xmin, then use QG2, where 44 ! Xmax and Xmin are the distances to the endpoints of the side. 45 REAL , PARAMETER :: QG_FACT = 5.0 46 47 INTEGER :: I , J , ISEG , NPTS , NOUT , ICON 48 REAL :: DVAL , DVALD , TEMP , U1 , U2 , UAV , UBV , TMPVAL , & 49 & TMPVALD , AUX(NDIM) 50 REAL ULIST(NVMAX2) , USEG(NVMAX,2) 51 INTEGER USIGN(NVMAX) , UFAC , USEGF(NVMAX) 52 LOGICAL LTEST1 , LTEST2 53 54 ! Variable Initializations 55 MODNAM = 'PSIDE2_TOX' ! 0 56 57 J = 1 58 DO I = 1 , NSEGS 59 ULIST(J) = UASEGS(I) ! 0 60 J = J + 1 61 ULIST(J) = UBSEGS(I) 62 J = J + 1 63 ENDDO 64 NPTS = 2*NSEGS ! 0 65 66 CALL HPSORT(NPTS,ULIST,NVMAX2) 67 68 DO I = 1 , NSEGS 69 USIGN(I) = 1 ! 0 70 IF ( UASEGS(I).GT.UBSEGS(I) ) THEN 71 USIGN(I) = -1 ! 0 72 TEMP = UASEGS(I) 73 UASEGS(I) = UBSEGS(I) 74 UBSEGS(I) = TEMP 75 ENDIF 76 IF ( UASEGS(I).EQ.UBSEGS(I) ) USIGN(I) = 0 ! 0 77 ENDDO 78 ISEG = 0 ! 0 79 80 DO I = 2 , NPTS 81 U1 = ULIST(I-1) ! 0 82 U2 = ULIST(I) 83 UFAC = 0 84 !***** 85 ! compare segment [u1,u2] against each ua,ub 86 !***** 87 IF ( U1.NE.U2 ) THEN 88 DO J = 1 , NSEGS ! 0 89 IF ( U1.GE.UASEGS(J) .AND. U2.LE.UBSEGS(J) ) & 90 & UFAC = UFAC + USIGN(J) 91 ENDDO 92 !***** 93 ! make table of segments and factors 94 !***** 95 IF ( UFAC.NE.0 ) THEN ! 0 96 ISEG = ISEG + 1 ! 0 97 USEG(ISEG,1) = U1 98 USEG(ISEG,2) = U2 99 USEGF(ISEG) = UFAC 100 ENDIF 101 ENDIF 102 ENDDO 103 !***** 104 ! CONSOLIDATE SEGMENTS IF iseg>1 105 !***** 106 NSEGS = ISEG ! 0 107 IF ( NSEGS.GT.1 ) THEN 108 DO ISEG = 2 , NSEGS ! 0 109 LTEST1 = USEG(ISEG,1).EQ.USEG(ISEG-1,2) ! 0 110 LTEST2 = USEGF(ISEG)*USEGF(ISEG-1).GT.0 111 IF ( LTEST1 .AND. LTEST2 ) THEN 112 USEGF(ISEG-1) = 0 ! 0 113 USEG(ISEG,1) = USEG(ISEG-1,1) 114 ENDIF 115 ENDDO 116 ENDIF 117 DVAL = 0.0 ! 0 118 DVALD = 0.0 119 IF ( NSEGS.GT.0 ) THEN 120 DO ISEG = 1 , NSEGS ! 0 121 IF ( USEGF(ISEG).NE.0 ) THEN ! 0 122 UAV = USEG(ISEG,1) ! 0 123 UBV = USEG(ISEG,2) 124 UFAC = USEGF(ISEG) 125 IF ( ABS(UBV-UAV).LT.QG_FACT*MIN(UAV,UBV) ) THEN 126 CALL QG2(UAV,UBV,TMPVAL,TMPVALD) ! 0 127 ELSE 128 CALL QATR3(UAV,UBV,EPSR,EPST,NDIM,IMIN,TMPVAL,TMPVALD,& 129 & ICON,NOUT,AUX) 130 ENDIF 131 DVAL = DVAL + UFAC*TMPVAL ! 0 132 DVALD = DVALD + UFAC*TMPVALD 133 ENDIF 134 ENDDO 135 ENDIF 136 137 CONTINUE ! 0 138 END
HyperKWIC - Version 1.00DD executed at 20:00 on 1 Mar 2018 | Personal or Academic or Evaluation User | Free for Non-Commercial, Non-Government Use