Model Change Bulletin MCB#5 BPIP (dated 04112) This is a formal notification of changes made to the Building Profile Input Program (BPIP) source code. BPIP has been upgraded with allocatable arrays while maintaining the basic functionality of the program. BPIP is available for downloading from the Related Programs sub area under the Dispersion Models area of the SCRAM web site. DISCUSSION OF SOURCE CODE CHANGES Allocatable arrays is a programming feature that allows a program's arrays to vary in size with respect to the amount of input data that needs to be stored in those arrays without having to recompile the source code. During execution, the program reads in the input data values and determines the maximum number of buildings, tiers per building, tier corners, and stacks needed for storage array sizing. The respective array sizes are set to these maximum values and then the program "rewinds" the input file. The input data are read again. But this time the input values are properly stored in the respectively sized arrays. There is no need to recompile the source code. BPIP will continue to serve non-PRIME and legacy models such as ISCST and ISCLT while BPIPPRM will be used primarily to generate building downwash input for models containing the PRIME algorithm such as ISC-PRIME and AERMOD. These should be the last modifications to BPIP. SOURCE CODE CHANGES The changes to BPIP are extensive. The underlying algorithms have remained the same but the use of allocatable arrays has caused the PARAMETER and COMMON statements to be deleted. All arguments are now passed through the CALL statements to the respective subroutines. Details of the changes can be viewed by using the DOS FC command or by using a text editor with a Compare function such as Ultraedit (http://www.ultraedit.com). Below is a copy of the change file produced using the FC command. The file is divided into short sections where the previous lines of code from BPIP (dated 95086) are on top and the changes to those lines of code appear below them. Most of the changes should be self explanatory to a Fortran programmer. Section by section changes Comparing files \OLD\BPIP.FOR and \NEW\BPIP.FOR ***** BPIP.FOR C * * C * BUILDING PROFILE INPUT PROGRAM (DATED 95086) * C * * C * *** SEE BPIP MODEL CHANGE BULLETIN MCB#4 *** * C * * ***** ..\NEW\BPIP.FOR C * * C * BUILDING PROFILE INPUT PROGRAM (DATED 04112) * C * * C * *** SEE BPIP MODEL CHANGE BULLETIN MCB#5 *** * C * * ***** ***** BPIP.FOR C * * C * (919) 541-5742 (8-N-1) * C * * ***** ..\NEW\BPIP.FOR C * * C * http://www.epa.gov/scram001 * C * * ***** ***** BPIP.FOR C Programmed by: Peter Eckhoff C EPA C MD-14 C Research Triangle Park, NC 27711 ***** ..\NEW\BPIP.FOR C Programmed by: Peter Eckhoff C US EPA C 4930 Page Rd, D243-01 C Research Triangle Park, NC 27711 ***** ***** BPIP.FOR C C Written to: FORTRAN 77 Standards C ***** ..\NEW\BPIP.FOR C C Written to: FORTRAN 90 Standards C ***** ***** BPIP.FOR C Other correction/updates. C March 27, 1995 - To fix a problem with the roof stack ***** ..\NEW\BPIP.FOR C Other correction/updates. C C March 27, 1995 - To fix a problem with the roof stack ***** ***** BPIP.FOR C C ************************************************************************** ***** ..\NEW\BPIP.FOR C C April 19, 2004 - Added allocatable arrays. C - No IMPLICIT variables; C all variables defined. C - Edited to Fortran 90 stds. using C Compaq Visual Fortran version 6.6. C C ************************************************************************** ***** ***** BPIP.FOR C 'Run description' (up to 78 characters) C 'ST' or 'LT' processing C 'Input Units Name' Conversion to meters factor ***** ..\NEW\BPIP.FOR C 'Run description' (up to 78 characters) C 'ST' or 'LT' processing for ISCST or ISCLT algorithms, respectively C 'Input Units Name' Conversion to meters factor ***** ***** BPIP.FOR C 'UTMN' (for no UTM) or 'UTMY'(for UTM coordinates processing), Plant North C Number of Buildings C Building 1 Name, Number of Tiers for Building 1, Base Elevation C Number of Corners for Tier 1, Tier 1 Height ***** ..\NEW\BPIP.FOR C 'UTMN' (for no UTM) or 'UTMY'(for UTM coordinates processing), Plant North C Number of Buildings C 'Building 1 Name', Number of Tiers for Building 1, Base Elevation C Number of Corners for Tier 1, Tier 1 Height ***** ***** BPIP.FOR C . C Building x Name, Number of Tiers for Building x C Number of Corners for Tier 1, Tier 1 Height ***** ..\NEW\BPIP.FOR C . C 'Building x Name', Number of Tiers for Building x C Number of Corners for Tier 1, Tier 1 Height ***** ***** BPIP.FOR C Number of Stacks C Stack 1 name, Base Elevation, Height, Stack 1 X -, and Y - Coordinates C . ***** ..\NEW\BPIP.FOR C Number of Stacks C 'Stack 1 name', Base Elevation, Height, Stack 1 X -, and Y - Coordinates C . ***** ***** BPIP.FOR C . C Stack s name, Base Elevation, Height, Stack s X -, and Y - Coordinates C ***** ..\NEW\BPIP.FOR C . C 'Stack s name', Base Elevation, Height, Stack s X -, and Y - Coordinates C ***** ***** BPIP.FOR C AP - X-COORDINATE TRANSLATED FROM PLANT NORTH C BB - DOUBLE PRECISION INPUT VALUE; GENERALLY AN Y-COORDINATE C BLDGIN - LABELLED COMMON CONTAINING ARRAYS OF BUILDING INPUT VALUES C BLDOUT - LABELLED COMMON CONTAINING TRANSLATED CORNER COORDINATES C BP - Y-COORDINATE TRANSLATED FROM PLANT NORTH C AU - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES ***** ..\NEW\BPIP.FOR C AP - X-COORDINATE TRANSLATED FROM PLANT NORTH C AU - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES ***** ***** BPIP.FOR C B - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES C BELEV - BASE ELEVATION OF A BUILDING C BET - VALUE IN CNRLIN THAT WHEN A PERPENDICULAR LINE DRAWN FROM A TIER ***** ..\NEW\BPIP.FOR C B - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES C BB - DOUBLE PRECISION INPUT VALUE; GENERALLY AN Y-COORDINATE C BELEV - ARRAY OF BUILDING BASE ELEVATIONS C BELEVV - DUMMY VARIABLE USED DURING INITIAL READ TO MIMIC BELEV C BET - VALUE IN CNRLIN THAT WHEN A PERPENDICULAR LINE DRAWN FROM A TIER ***** ***** BPIP.FOR C CORNERS, BET IS POSITIVE. C BTN - NAME OF STRUCTURE C BU - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES ***** ..\NEW\BPIP.FOR C CORNERS, BET IS POSITIVE. C BP - Y-COORDINATE TRANSLATED FROM PLANT NORTH C BTN - NAME OF STRUCTURE C BTNV - USED AS DUMMY VARIABLE IN INITIAL READ C BU - TEMPORARY STORAGE VARIABLE ASSOCIATED WITH UTM COORDINATES ***** ***** BPIP.FOR C C - NUMBER USED TO INDEX A BUILDING TIER (BLDG# - 1) * MXTRS + TIER# C WHERE 4 REPRESENTS THE MAX NUMBER OF TIERS PRE BUILDING C C1 - BUILDING TIER NUMBER COMBINABLE WITH BUILDING TIER NUMBER C2 ***** ..\NEW\BPIP.FOR C C - NUMBER USED TO INDEX A BUILDING TIER (BLDG# - 1) * MXTRS + TIER# C C1 - BUILDING TIER NUMBER COMBINABLE WITH BUILDING TIER NUMBER C2 ***** ***** BPIP.FOR C INTERCEPTS THE SIDE BETWEEN THE TWO CORNERS OF THE TIER. C CONV - FACTOR TO CONVERT USER'S UNITS TO METERS C CNVFLG - FLAG TO INDICATE A CONVERSION FACTOR OF 1.00 OR NOT C CSA - COSINE OF ANG ***** ..\NEW\BPIP.FOR C INTERCEPTS THE SIDE BETWEEN THE TWO CORNERS OF THE TIER. C CNVFLG - FLAG TO INDICATE A CONVERSION FACTOR OF 1.00 OR NOT C CONV - FACTOR TO CONVERT USER'S UNITS TO METERS C CSA - COSINE OF ANG ***** ***** BPIP.FOR C D - WIND DIRECTION SUBSCRIPT OR INDEX C DDEG - INC'ENTAL WIND DIRECTION AND INITIAL WIND DIRECTION C DE - CURRENT DIRECTION - LAGS ACTUAL DIRECTION - USED IN MXBWH ***** ..\NEW\BPIP.FOR C D - WIND DIRECTION SUBSCRIPT OR INDEX C D1 - DOWNWIND DISTANCE FROM A CORNER TO A STACK C D2 - DOWNWIND DISTANCE FROM A ANOTHER CORNER TO A STACK C DDEG - INCREMENTAL WIND DIRECTION AND INITIAL WIND DIRECTION C DE - CURRENT DIRECTION - LAGS ACTUAL DIRECTION - USED IN MXBWH ***** ***** BPIP.FOR C DISTMN - MINIMUM DISTANCE BETWEEN BUILDING TIER PAIRS C DMDxx - NUMBER OF OUTPUT VALUES PER LINE C DPBH - COMMON HEIGHT OF A COMBINED TIERS FOR A SPECIFIC WIND FLOW ***** ..\NEW\BPIP.FOR C DISTMN - MINIMUM DISTANCE BETWEEN BUILDING TIER PAIRS C DPBH - COMMON HEIGHT OF A COMBINED TIERS FOR A SPECIFIC WIND FLOW ***** ***** BPIP.FOR C DPBW - PROJECTED WIDTH OF COMBINED TIERS FOR A SPECIFIC WIND FLOW C DR - WIND DIRECTION FROM A CORNER TO A STACK C DTR - DEGREES TO RADIANS CONVERSION FACTOR ***** ..\NEW\BPIP.FOR C DPBW - PROJECTED WIDTH OF COMBINED TIERS FOR A SPECIFIC WIND FLOW C DTR - DEGREES TO RADIANS CONVERSION FACTOR ***** ***** BPIP.FOR C DX2 - MAXIMUM OF TWO X-COORDINATES C ELEV - LABELLED COMMON CONTAINING BUILDING AND STACK BASE ELEVATIONS C FLG1 - FLAG FOR STACK INDICATING STACK'S X COORDINATE MAYBE WITHIN SIZ ***** ..\NEW\BPIP.FOR C DX2 - MAXIMUM OF TWO X-COORDINATES C FLG1 - FLAG FOR STACK INDICATING STACK'S X COORDINATE MAYBE WITHIN SIZ ***** ***** BPIP.FOR C GEPIN - FLAG INDICATING SOURCE IS IN GEP INFLUENCE OF STRUCTURE C C GETDAT - GET DATE MICROSOFT LIBRARY FUNCTION C GETTIM - GET TIME MICROSOFT LIBRARY FUNCTION C GFS - GAP-FILLING STRUCTURE. USED TO JOIN TWO SUFFICIENTLY TIERS INTO ***** ..\NEW\BPIP.FOR C GEPIN - FLAG INDICATING SOURCE IS IN GEP INFLUENCE OF STRUCTURE C C GFS - GAP-FILLING STRUCTURE. USED TO JOIN TWO SUFFICIENTLY TIERS INTO ***** ***** BPIP.FOR C ONE COMBINED STRUCTURE C GP - LABELLED COMMON CONTAINING GEP DATA C GPC - SUBROUTINE THAT SET GEPIN TO 1 AND DETERMINES MAX GEP STACK HEIGHT ***** ..\NEW\BPIP.FOR C ONE COMBINED STRUCTURE C GPC - SUBROUTINE THAT SET GEPIN TO 1 AND DETERMINES MAX GEP STACK HEIGHT ***** ***** BPIP.FOR C GTLIST - ARRAY OF TIER NUMBERS USED TO CALCULATE A GEP STACK HEIGHT VALUE C GTNM - LABELLED COMMON CONTAINING TIERS AFFECTING STACKS C GTNUM - COUNTER WITH NUMBER OF TIERS USED TO CALCULATE A GEP STACK HEIGHT ***** ..\NEW\BPIP.FOR C GTLIST - ARRAY OF TIER NUMBERS USED TO CALCULATE A GEP STACK HEIGHT VALUE C GTNUM - COUNTER WITH NUMBER OF TIERS USED TO CALCULATE A GEP STACK HEIGHT ***** ***** BPIP.FOR C I - BUILDING SUBSCRIPT OR INDEX C Ix - COUNTER IN A DO LOOP C IBET - FLAG IN DISLIN THAT WHEN SET INDICATES THAT A STACK IS UP TO ***** ..\NEW\BPIP.FOR C I - BUILDING SUBSCRIPT OR INDEX C IBET - FLAG IN DISLIN THAT WHEN SET INDICATES THAT A STACK IS UP TO ***** ***** BPIP.FOR C IDAY - DAY C IG - FLAG TO INDICATE SINGLE OR COMBINED TIER CALCULATIONS C IHR - HOUR ***** ..\NEW\BPIP.FOR C IDAY - DAY C IFILE - UNIT NUMBER USED IN DEBUGGING STACK - DIRECTION RELATIONSHIPS C IG - FLAG TO INDICATE SINGLE OR COMBINED TIER CALCULATIONS C IGMT - DIFFERENCE BETWEEN LOCAL AND GREENWICH(UNIVERSAL) MEAN TIME C IHR - HOUR ***** ***** BPIP.FOR C IMON - MONTH C INTRCP - LABELLED COMMON CONTAINING THE INTERCEPT COORDINATES BETWEEN A C STACK AND THE SIDE OF A TIER C ISEC - SECOND ***** ..\NEW\BPIP.FOR C IMON - MONTH C ISEC - SECOND ***** ***** BPIP.FOR C FALL UNDER THE L5SQAT DEFINITION C LTN1 - L OF FIRST COMBINABLE TIER C LTN2 - L OF SECOND COMBINABLE TIER OF TWO TIERS C LTN - GREATER OF LTN1 OR LTN2 C LS - STACK INDEX ***** ..\NEW\BPIP.FOR C FALL UNDER THE L5SQAT DEFINITION C LS - STACK INDEX ***** ***** BPIP.FOR C LT - TIER INDEX C M - SLOPE OF A TIER SIDE ***** ..\NEW\BPIP.FOR C LT - TIER INDEX C LTN - GREATER OF LTN1 OR LTN2 C LTN1 - L OF FIRST COMBINABLE TIER C LTN2 - L OF SECOND COMBINABLE TIER OF TWO TIERS C M - SLOPE OF A TIER SIDE ***** ***** BPIP.FOR C MI - AN ARRAY OF BUILDING NUMBERS C MIJ - LABELLED COMMON CONTAINING BUILDING TIER NUMBER C MJ - AN ARRAY OF TIER NUMBERS ***** ..\NEW\BPIP.FOR C MI - AN ARRAY OF BUILDING NUMBERS C MJ - AN ARRAY OF TIER NUMBERS ***** ***** BPIP.FOR C PROJECTED WIDTH C MTNM - LABELLED COMMON CONTAINING TIER(S) PRODUCING MAXIMUM WAKE EFFECT C HEIGHT C MTNUM - COUNTER HOLDING THE NUMBER OF COMBINED TIERS FOR A MAXIMUM ***** ..\NEW\BPIP.FOR C PROJECTED WIDTH C MTNUM - COUNTER HOLDING THE NUMBER OF COMBINED TIERS FOR A MAXIMUM ***** ***** BPIP.FOR C MW - ARRAY HOLDING MAXIMUM WIDTHS BY STACK AND SECTOR C MXB - LABELLED COMMON CONTAINING MAXIMUM WAKE EFFECT VALUES C MXN - LABELLED COMMON CONTAINING TIER MAX/MIN CORNERS C MXBHW - SUBROUTINE THAT CALCULATES BUILDING WAKE EFFECT HEIGHT ***** ..\NEW\BPIP.FOR C MW - ARRAY HOLDING MAXIMUM WIDTHS BY STACK AND SECTOR C MXBHW - SUBROUTINE THAT CALCULATES BUILDING WAKE EFFECT HEIGHT ***** ***** BPIP.FOR C NDIR - NUMBER OF WIND DIRECTIONS TO BE PROCESSED C NS - NUMBER OF STACKS ENTERED C NTRS - NUMBER OF TIERS (MAXIMUM OF 4) / BUILDING C PBH - BUILDING HEIGHT BY BUILDING TIER NUMBER C PBW - PROJECTED BUILDING WIDTH BY BUILDING TIER NUMBER ***** ..\NEW\BPIP.FOR C NDIR - NUMBER OF WIND DIRECTIONS TO BE PROCESSED C NDV - NUMBER OF SIDES TO A TIER ENTERED C NS - NUMBER OF STACKS ENTERED C NTRS - NUMBER OF TIERS PER BUILDING C NTRSV - NUMBER OF TIERS PER BUILDING C PBH - BUILDING HEIGHT BY BUILDING TIER NUMBER C PBW - PROJECTED BUILDING WIDTH BY BUILDING TIER NUMBER ***** ***** BPIP.FOR C SB - STACK BASE ELEVATION C SH - STACK HEIGHT C SM - SLOPE OF A LINE ***** ..\NEW\BPIP.FOR C SB - STACK BASE ELEVATION C SBV - USED AS DUMMY VARIABLE DURING INITIAL READ C SH - STACK HEIGHT C SHV - USED AS DUMMY VARIABLE DURING INITIAL READ C SM - SLOPE OF A LINE ***** ***** BPIP.FOR C SNM - TEMPORARY STACK NAME USED TO CHECK FOR BLANK SPACES IN NAME - STKN C STKN - STACK NAME C SWT - FLAG INDICATING WHETHER TO CALCULATE VALUES FOR ISCST OR ISCLT ***** ..\NEW\BPIP.FOR C SNM - TEMPORARY STACK NAME USED TO CHECK FOR BLANK SPACES IN NAME - STKN C SS - USED AS STACK INDEX C STKN - STACK NAME C STKNV - USED AS DUMMY VARIABLE DURING INITIAL READ C SWT - FLAG INDICATING WHETHER TO CALCULATE VALUES FOR ISCST OR ISCLT ***** ***** BPIP.FOR C TH - HEIGHT OF A TIER - DIMENSIONED BY BUILDING NUMBER AND TIER NO. C TITLE - DATA TITLE OR IDENTIFICATION STATEMENT (UP TO 78 CHARACTERS) ***** ..\NEW\BPIP.FOR C TH - HEIGHT OF A TIER - DIMENSIONED BY BUILDING NUMBER AND TIER NO. C THV - USED AS DUMMY VARIABLE DURING INITIAL READ C TITLE - DATA TITLE OR IDENTIFICATION STATEMENT (UP TO 78 CHARACTERS) ***** ***** BPIP.FOR C X1 - FIRST OF TWO CONSECUTIVE TIER CORNER X-COORDINATES C X2 - SECOND OF TWO CONSECUTIVE TIER CORNER X-COORDINATES C X11 - X COORDINATE OF FIRST TIER CORNER OF FIRST BUILDING ***** ..\NEW\BPIP.FOR C X1 - FIRST OF TWO CONSECUTIVE TIER CORNER X-COORDINATES C X11 - X COORDINATE OF FIRST TIER CORNER OF FIRST BUILDING ***** ***** BPIP.FOR C X12 - X COORDINATE OF SECOND TIER CORNER OF FIRST BUILDING C X21 - X COORDINATE OF FIRST TIER CORNER OF SECOND BUILDING ***** ..\NEW\BPIP.FOR C X12 - X COORDINATE OF SECOND TIER CORNER OF FIRST BUILDING C X2 - SECOND OF TWO CONSECUTIVE TIER CORNER X-COORDINATES C X21 - X COORDINATE OF FIRST TIER CORNER OF SECOND BUILDING ***** ***** BPIP.FOR C X22 - X COORDINATE OF SECOND TIER CORNER OF SECOND BUILDING C XC - X COORDINATE OF A CORNER BY NUMBER C XCOMP - DOUBLE PRECISION DIFFERENCE BETWEEN A STACK AND TIER CORNER ***** ..\NEW\BPIP.FOR C X22 - X COORDINATE OF SECOND TIER CORNER OF SECOND BUILDING C XC - X COORDINATE OF A TRANSLATED TIER CORNER C XCOMP - DOUBLE PRECISION DIFFERENCE BETWEEN A STACK AND TIER CORNER ***** ***** BPIP.FOR C XMX - TEMPORARY STORAGE OF FURTHEST EAST X COORDINATE VALUE C XP - X COORDINATE OF A TRANSLATED TIER CORNER C XPSTK - X COORDINATE OF A TRANSLATED STACK ***** ..\NEW\BPIP.FOR C XMX - TEMPORARY STORAGE OF FURTHEST EAST X COORDINATE VALUE C XPSTK - X COORDINATE OF A TRANSLATED STACK ***** ***** BPIP.FOR C Y1 - FIRST OF TWO CONSECUTIVE TIER CORNER Y-COORDINATES C Y2 - SECOND OF TWO CONSECUTIVE TIER CORNER Y-COORDINATES C Y11 - Y COORDINATE OF FIRST TIER CORNER OF FIRST BUILDING ***** ..\NEW\BPIP.FOR C Y1 - FIRST OF TWO CONSECUTIVE TIER CORNER Y-COORDINATES C Y11 - Y COORDINATE OF FIRST TIER CORNER OF FIRST BUILDING ***** ***** BPIP.FOR C Y12 - Y COORDINATE OF SECOND TIER CORNER OF FIRST BUILDING C Y21 - Y COORDINATE OF FIRST TIER CORNER OF SECOND BUILDING ***** ..\NEW\BPIP.FOR C Y12 - Y COORDINATE OF SECOND TIER CORNER OF FIRST BUILDING C Y2 - SECOND OF TWO CONSECUTIVE TIER CORNER Y-COORDINATES C Y21 - Y COORDINATE OF FIRST TIER CORNER OF SECOND BUILDING ***** ***** BPIP.FOR C Y22 - Y COORDINATE OF SECOND TIER CORNER OF SECOND BUILDING C YC - Y COORDINATE OF A CORNER BY NUMBER C YCOMP - DOUBLE PRECISION DIFFERENCE BETWEEN A STACK AND TIER CORNER ***** ..\NEW\BPIP.FOR C Y22 - Y COORDINATE OF SECOND TIER CORNER OF SECOND BUILDING C YC - Y COORDINATE OF A TRANSLATED TIER CORNER C YCOMP - DOUBLE PRECISION DIFFERENCE BETWEEN A STACK AND TIER CORNER ***** ***** BPIP.FOR C YMX - TEMPORARY STORAGE OF FURTHEST EAST Y COORDINATE VALUE C YP - Y COORDINATE OF A TRANSLATED TIER CORNER C YPSTK - Y COORDINATE OF A TRANSLATED STACK ***** ..\NEW\BPIP.FOR C YMX - TEMPORARY STORAGE OF FURTHEST EAST Y COORDINATE VALUE C YPSTK - Y COORDINATE OF A TRANSLATED STACK ***** ***** BPIP.FOR C LOGICAL FLG1, FLG2 REAL L2, L5, MHWE, MXPBH, MXPBW, MH, MW, LTN1, LTN2, LTN INTEGER IHR, IMIN, ISEC, IX, IYR, IMON, IDAY, C, C1, C2, CH, * CNVFLG, D, DE, GEPIN, GTLIST, GTNUM, MTNUM, MTLIST, S, * T1, T2, TL1, TL2, TLIST, TLIST2, TN1, TNUM, TNUM2, UTM ***** ..\NEW\BPIP.FOR C IMPLICIT NONE LOGICAL FLG1, FLG2 INTEGER C, C1, C2, CH, CNVFLG, * D, DE, DFLG, GEPIN, GTLIST, GTNUM INTEGER IDAY, IMON, IYR, * IGMT, IHR, IMIN, ISEC, IX, DATE_TIME(8) INTEGER I, IBET, ICF, IFILE, IG, * II, ISF, ISS, IZ, * J, JJ, K, K1, K2, KK, L, L5SQAT, LB, LD, LD1, LD2, LT, * LFLAT, LS INTEGER M, MB, MBT, MD, MI, MJ, ML, MSK, * MT, MTNUM, MTLIST, MTS, MXTRS INTEGER NB, ND, ND16, NDIR, NDV, * NS, NTRS, NTRSV, PN, * S, SWT, * T1, T2, TL1, TL2, TLIST, TLIST2, TN1, TNUM, TNUM2, UTM ***** ***** BPIP.FOR DOUBLE PRECISION A, B, AA, BB, DIRT, DIRTT, DTR2, + UEAST, UNORTH, XCOMP, YCOMP CHARACTER*2 SWTN CHARACTER*4 UTMP CHARACTER*8 BTN, STKN, SNM CHARACTER*10 UNTS CHARACTER*78 TITLE ***** ..\NEW\BPIP.FOR REAL ADJ, ANG, AP, AU, BELEV, BELEVV, BET, BP, BU, & CONV, CSA, CXMN, CXMX, CYMN, CYMX, DDEG, DIF, & DHWE, DIST, DISTMN, & DPBH, DPBW, DTR, & G65, GDIRS, GEP, GEPBH, GEPBW REAL HT, HTA, HTC, & L2, L5, LTN1, LTN2, LTN, & MH, MHWE, & MW, MXPBH, MXPBW, PNORTH, PV, R, & SB, SBV, SH, SHV, SNA, TH, THV, TW, W, WS REAL X1, X11, X12, X2, X21, X22, & XC, XI, XMAX, XMIN, XMN, XMX, XPSTK, XS, & Y1, Y11, Y12, Y2, Y21, Y22, & YC, YI, YMAX, YMIN, YMN, YMX, YPSTK, YS DOUBLE PRECISION A, B, AA, BB, DIRT, DIRTT, DTR2, + UEAST, UNORTH, X, XCOMP, Y, YCOMP CHARACTER(LEN=2) SWTN CHARACTER(LEN=4) UTMP CHARACTER(LEN=8) BTN, BTNV, STKN, STKNV, SNM CHARACTER(LEN=10) UNTS CHARACTER(LEN=12) REAL_CLOCK(3) CHARACTER(LEN=78) TITLE ***** ***** BPIP.FOR C C INITIAL PARAMETER SETTINGS ***** ..\NEW\BPIP.FOR C C ALLOCATABLE SUBSCRIPT FORMAT: (BUILDING OR STACK #, WD OR TIER #, SIDE #) C ALLOCATABLE :: X(:,:,:), Y(:,:,:), ND(:,:) ALLOCATABLE :: XC(:,:), YC(:,:) ALLOCATABLE :: DFLG(:,:), DHWE(:), DPBH(:), DPBW(:) ALLOCATABLE :: BELEV(:) ALLOCATABLE :: GEP(:), GEPBH(:), GEPBW(:), + GEPIN(:,:,:,:) ALLOCATABLE :: MHWE(:,:), MXPBH(:,:), MXPBW(:,:) ALLOCATABLE :: XMAX(:), XMIN(:), YMAX(:), YMIN(:) ALLOCATABLE :: MI(:,:), MJ(:,:) ALLOCATABLE :: TNUM2(:), TLIST2(:,:) ALLOCATABLE :: GTNUM(:), GTLIST(:,:), GDIRS(:) ALLOCATABLE :: MTNUM(:,:), MTLIST(:,:,:) ALLOCATABLE :: BTN(:), NTRS(:), W(:), HT(:), TH(:,:) ALLOCATABLE :: STKN(:), SB(:), SH(:), XS(:), YS(:) ALLOCATABLE :: DIRT(:), DISTMN(:,:), LFLAT(:,:) ALLOCATABLE :: TNUM(:), TLIST(:,:) ALLOCATABLE :: MH(:,:), MW(:,:) C C INITIAL PARAMETER SETTINGS ***** ***** BPIP.FOR C C MAX NUMBER OF BUILDINGS MB = 8 C MAX NUMBER OF TIERS/BUILDING MT = 4 C MAX NUMBER OF SIDES/TIER MTS = 8 C MAX NUMBER OF STACK SOURCES MSK = 14 C MAX BUILDING TIER NUMBER MBT = 32 (MB * MT) C MAX NUMBER OF SECTORS - ST MD = 36 C MAX NUMBER OF SECTORS - LT ML = 16 C C ******************************************************************** PARAMETER (MB = 8, MT = 4, MTS = 8, MBT = MB*MT , MSK = 14, * * MD = 36, ML = 16) * C * * C * Remember to also change the parameter settings in the * C * subroutines ! * C ******************************************************************** C C DIMENSION SUBSCRIPT FORMAT: (BUILDING OR STACK #, WD OR TIER #, SIDE #) C COMMON /BLDGIN/ X(MB, MT, MTS), Y(MB, MT, MTS), ND(MB, MT) COMMON /BLDOUT/ XC(MBT,MTS), YC(MBT,MTS) COMMON /DE/ DE, DFLG(MSK, MD), DHWE(MSK), DPBH(MSK), DPBW(MSK) COMMON /ELEV/ BELEV(MB), SB(MSK) COMMON /GP/ GEP(MSK), GEPBH(MSK), GEPBW(MSK), + GEPIN(MSK,MBT,MBT,2) COMMON /INTRCP/ XI,YI COMMON /MXB/ MHWE(MSK, MD), MXPBH(MSK, MD), MXPBW(MSK, MD) COMMON /MXN/ XMAX(MBT), XMIN(MBT), YMAX(MBT), YMIN(MBT) COMMON /MIJ/ MI(MSK,2), MJ(MSK,2) COMMON /TNM/ TNUM2(MBT), TLIST2(MBT,MBT) COMMON /GTNM/ GTNUM(MSK), GTLIST(MSK,MBT), GDIRS(MSK) COMMON /MTNM/ MTNUM(MSK,2), MTLIST(MSK,MBT,2) DIMENSION BTN(MB), NTRS(MB), W(MBT), HT(MBT), TH(MB, MT) DIMENSION STKN(MSK), SH(MSK), XS(MSK), YS(MSK) DIMENSION DIRT(MTS), DISTMN(MBT, MBT), LFLAT(MSK, MBT) DIMENSION TNUM(MBT), TLIST(MBT,MBT) DIMENSION MH(MSK, ML), MW(MSK, ML) DIMENSION XP(MSK), YP(MSK) DE = 0 ***** ..\NEW\BPIP.FOR C C IG = 1 MD = 36 ML = 16 MT = 0 MTS = 0 DE = 0 ***** ***** BPIP.FOR G65 = 65. MXTRS = MT C C READ INPUT DATA CONTAINING BUILDING AND STACK DATA C WRITE(*,*) ' ' WRITE(*,*) 'READING INPUT DATA FROM FILE.' WRITE(*,*) ' ' ***** ..\NEW\BPIP.FOR G65 = 65. C READ THE INPUT FILE TO FIND THE MAXIMUM VALUES ***** ***** BPIP.FOR READ(10,*) TITLE ***** ..\NEW\BPIP.FOR READ(10,*) TITLE WRITE (12,1) TITLE WRITE (14,1) TITLE READ(10,*) SWTN READ(10,*) UNTS, CONV READ(10,*) UTMP, PNORTH READ(10,*) NB MB = NB DO 10 I = 1, NB READ(10,*) BTNV, NTRSV, BELEVV IF (NTRSV .GE. MT) THEN MT = NTRSV END IF DO 20 J = 1, NTRSV READ(10,*) NDV, THV IF (NDV .GE. MTS) THEN MTS = NDV END IF DO 30 K = 1, NDV READ(10,*) AA, BB 30 CONTINUE 20 CONTINUE 10 CONTINUE MBT = MB * MT MXTRS = MT READ(10,*) NS MSK = NS DO 40 S = 1, NS READ (10,*) STKNV, SBV, SHV, AA, BB 40 CONTINUE REWIND (10) C ALLOCATE AND INITIALIZE THE ARRAYS BASED ON C THE MAXIMUM PARAMETER VALUES FOUND ALLOCATE (X(MB, MT, MTS), Y(MB, MT, MTS), ND(MB, MT)) DO I = 1, MB; DO J = 1, MT; ND(I,J) = 0; DO K = 1, MTS; X(I,J,K) = 0.0; Y(I,J,K) = 0.0; END DO; END DO; END DO ALLOCATE (XC(MBT,MTS), YC(MBT,MTS)) DO I = 1, MBT; DO J = 1, MTS; XC(I,J) = 0.0; YC(I,J) = 0.0 END DO; END DO ALLOCATE (DFLG(MSK, MD), DHWE(MSK), DPBH(MSK),DPBW(MSK)) DO I = 1, MSK; DHWE(I) = 0.0; DPBH(I) = 0.0; DPBW(I) = 0.0; DO J = 1, MD; DFLG (I,J) = 0; END DO; END DO ALLOCATE (BELEV(MB)) DO I = 1, MB; BELEV(I) = 0.0;END DO ALLOCATE (GEP(MSK), GEPBH(MSK), GEPBW(MSK)) DO I = 1, MSK; GEP(I) = 0.0; GEPBH(I) = 0.0; GEPBW(I) = 0.0 END DO ALLOCATE (GEPIN(MSK,MBT,MBT,2)) DO I = 1, MSK; DO J = 1, MBT; DO K = 1, MBT; DO L = 1, 2 GEPIN(I,J,K,L) = 0; END DO; END DO; END DO; END DO ALLOCATE (MHWE(MSK, MD), MXPBH(MSK, MD), MXPBW(MSK, MD)) DO I = 1, MSK; DO J = 1, MD; MHWE(I,J) = 0.0; MXPBH(I,J) = 0.0; MXPBW(I,J) = 0.0; END DO; END DO ALLOCATE (XMAX(MBT), XMIN(MBT), YMAX(MBT), YMIN(MBT)) DO I = 1 , MBT; XMAX(I) = 0.0; XMIN(I) = 0.0; YMAX(I) = 0.0 YMIN(I) = 0.0 END DO ALLOCATE (MI(MSK,2), MJ(MSK,2)) DO I = 1, MSK; DO J = 1,2; MI(I,J) = 0; MJ(I,J) = 0; END DO; END DO ALLOCATE (TNUM2(MBT), TLIST2(MBT,MBT)) DO I = 1, MBT; TNUM2(I) = 0; DO J = 1,MBT; TLIST2(I,J) = 0; END DO; END DO ALLOCATE (GTNUM(MSK), GTLIST(MSK,MBT), GDIRS(MSK)) DO I = 1, MSK; GTNUM(I) = 0; GDIRS(I) = 0.0; DO J = 1, MBT; GTLIST(I,J) = 0; END DO; END DO ALLOCATE (MTNUM(MSK,2), MTLIST(MSK,MBT,2)) DO I = 1, MSK; DO J = 1, 2; MTNUM(I,J) = 0; DO K = 1, MBT; MTLIST(I,K,J) = 0; END DO; END DO; END DO ALLOCATE (BTN(MB), NTRS(MB), W(MBT), HT(MBT), TH(MB, MT)) DO I = 1, MB; BTN(I) = " "; NTRS(I) = 0; END DO DO I = 1, MBT; W(I) = 0.0; HT(I) = 0.0; END DO DO I = 1, MB; DO J = 1, MT; TH(I,J) = 0.0; END DO; END DO ALLOCATE (STKN(MSK), SB(MSK), SH(MSK), XS(MSK), YS(MSK)) DO I = 1 , MSK; STKN(I) = " "; SB(I) = 0.0; SH(I) = 0.0 XS(I) = 0.0; YS(I) = 0.0; END DO ***** ***** BPIP.FOR CALL GETTIM (IHR, IMIN, ISEC, IX) CALL GETDAT (IYR, IMON, IDAY) IYR = MOD(IYR,100) WRITE (12, 461) ***** ..\NEW\BPIP.FOR ALLOCATE (DIRT(MTS), DISTMN(MBT, MBT), LFLAT(MSK, MBT)) DO I = 1, MTS; DIRT(I) = 0.0; END DO DO I = 1, MBT; DO J = 1, MBT; DISTMN(I,J) = 0.0; END DO;END DO DO I = 1, MSK; DO J = 1, MBT; LFLAT(I,J) = 0; END DO; END DO ALLOCATE (TNUM(MBT), TLIST(MBT,MBT)) DO I = 1, MBT; TNUM(I) = 0; DO J = 1, MBT; TLIST(I,J) = 0; END DO; END DO ALLOCATE (MH(MSK, ML), MW(MSK, ML)) DO I = 1, MSK; DO J = 1, ML; MH(I,J) = 0.0; MW(I,J) = 0.0; END DO; END DO C C READ INPUT DATA CONTAINING BUILDING AND STACK DATA C WRITE(*,*) ' ' WRITE(*,*) 'READING INPUT DATA FROM FILE.' WRITE(*,*) ' ' READ(10,*) TITLE CALL DATE_AND_TIME (REAL_CLOCK (1), REAL_CLOCK (2), * REAL_CLOCK (3), DATE_TIME) IYR = DATE_TIME(1) IMON = DATE_TIME(2) IDAY = DATE_TIME(3) C IGMT = DATE_TIME(4) !C TIME DIFFERENCE C WRT COORDINATED UNIVERSAL TIME (UTC) IHR = DATE_TIME(5) IMIN = DATE_TIME(6) ISEC = DATE_TIME(7) C IX = DATE_TIME(8) !C MILLISECONDS WRITE (12, 461) ***** ***** BPIP.FOR IF(SWT .EQ. 2) THEN WRITE(*,*) 'The SWTN variable, ',SWTN,' is incorrectly ', + 'entered.' STOP ***** ..\NEW\BPIP.FOR IF(SWT .EQ. 2) THEN WRITE(*,*) '**ERR: The SWTN variable, ',SWTN,' is', + ' incorrectly entered.' WRITE(*,*) ' Please use ST, st, LT, or', + ' lt (lowercase LT) as input.' STOP ***** ***** BPIP.FOR WRITE(14,3) UNTS, CONV C IF CNVFLG IS 1, THE UNITS ARE CONSIDERED TO BE IN METERS CNVFLG = 0 IF (ABS(CONV - 1.00) .LT. .05) CNVFLG = 1 ***** ..\NEW\BPIP.FOR WRITE(14,3) UNTS, CONV CNVFLG = 0 C IF CONV IS 1 OR ALMOST 1, THE UNITS ARE CONSIDERED TO BE IN METERS C AND CNVFLG IS SET TO 1 TO INDICATE UNITS ARE IN METERS IF (ABS(CONV - 1.00) .LT. .05) CNVFLG = 1 ***** ***** BPIP.FOR DO 10 I = 1, NB READ(10,*) BTN(I), NTRS(I), BELEV(I) ***** ..\NEW\BPIP.FOR DO 15 I = 1, NB READ(10,*) BTN(I), NTRS(I), BELEV(I) ***** ***** BPIP.FOR DO 20 J = 1, NTRS(I) READ(10,*) ND(I, J), TH(I, J) ***** ..\NEW\BPIP.FOR DO 25 J = 1, NTRS(I) READ(10,*) ND(I, J), TH(I, J) ***** ***** BPIP.FOR DO 30 K = 1, ND(I, J) READ(10,*) AA, BB ***** ..\NEW\BPIP.FOR DO 35 K = 1, ND(I, J) READ(10,*) AA, BB ***** ***** BPIP.FOR 30 CONTINUE 20 CONTINUE 10 CONTINUE ***** ..\NEW\BPIP.FOR 35 CONTINUE 25 CONTINUE 15 CONTINUE ***** ***** BPIP.FOR WRITE (14,42) DO 40 S = 1, NS READ (10,*) STKN(S), SB(S), SH(S), AA, BB ***** ..\NEW\BPIP.FOR WRITE (14,42) DO 50 S = 1, NS READ (10,*) STKN(S), SB(S), SH(S), AA, BB ***** ***** BPIP.FOR WRITE (14,47) GO TO 40 END IF ***** ..\NEW\BPIP.FOR WRITE (14,47) GO TO 50 END IF ***** ***** BPIP.FOR 48 CONTINUE 40 CONTINUE ***** ..\NEW\BPIP.FOR 48 CONTINUE 50 CONTINUE ***** ***** BPIP.FOR L5SQAT = 0 DO 70 LS = 1, NS DO 70 LB = 1, NB DO 70 LT = 1, NTRS(LB) C = (LB-1) * MXTRS + LT ***** ..\NEW\BPIP.FOR L5SQAT = 0 DO LS = 1, NS DO LB = 1, NB DO LT = 1, NTRS(LB) C = (LB-1) * MXTRS + LT ***** ***** BPIP.FOR DIRTT = 0.0 DO 74 LD = 1, ND(LB, LT) IF (YS(LS) .EQ. Y(LB,LT,LD)) THEN ***** ..\NEW\BPIP.FOR DIRTT = 0.0 DO LD = 1, ND(LB, LT) IF (YS(LS) .EQ. Y(LB,LT,LD)) THEN ***** ***** BPIP.FOR END IF 74 CONTINUE DO 76 LD = 1, ND(LB,LT) LD1 = LD ***** ..\NEW\BPIP.FOR END IF END DO DO LD = 1, ND(LB,LT) LD1 = LD ***** ***** BPIP.FOR DIRTT = DIRTT + AA 76 CONTINUE 77 CONTINUE ***** ..\NEW\BPIP.FOR DIRTT = DIRTT + AA END DO 77 CONTINUE ***** ***** BPIP.FOR END IF 70 CONTINUE IF (L5SQAT .EQ. 0) THEN ***** ..\NEW\BPIP.FOR END IF END DO END DO END DO IF (L5SQAT .EQ. 0) THEN ***** ***** BPIP.FOR WRITE(*,*) ' ' C ***** ..\NEW\BPIP.FOR WRITE(*,*) ' ' C ***** ***** BPIP.FOR C WRITE(*,*) ' ' ***** ..\NEW\BPIP.FOR C WRITE(*,*) ' ' ***** ***** BPIP.FOR IF (SWT .EQ. 0) THEN DDEG = 10 NDIR = MD ***** ..\NEW\BPIP.FOR IF (SWT .EQ. 0) THEN DDEG = 10. NDIR = MD ***** ***** BPIP.FOR ND16 = ML DMD8 = 8 DMD12 = 12 C ***** ..\NEW\BPIP.FOR ND16 = ML C ***** ***** BPIP.FOR C and the side of another structure CALL CNRLIN(X21, Y21, X22, Y22, BET, DIST, X11, Y11) C If the intercept is between the two corners of the ***** ..\NEW\BPIP.FOR C and the side of another structure CALL CNRLIN(XI, YI, X21, Y21,X22,Y22,BET,DIST,X11,Y11) C If the intercept is between the two corners of the ***** ***** BPIP.FOR END IF CALL CNRLIN(X11, Y11, X12, Y12, BET, DIST, X21, Y21) C If the intercept is between the two corners of the ***** ..\NEW\BPIP.FOR END IF CALL CNRLIN(XI,YI,X11,Y11,X12,Y12,BET, DIST, X21, Y21) C If the intercept is between the two corners of the ***** ***** BPIP.FOR TNUM2(C) = 0 C CALCULATE PROJECTED TIER WIDTH, TW CALL WIDTH(ANG, I, J, C, TW) W(C) = TW ***** ..\NEW\BPIP.FOR TNUM2(C) = 0 C CALCULATE PROJECTED TIER WIDTH, TW CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, I, J, C, TW) W(C) = TW ***** ***** BPIP.FOR C Call subroutine to calculate a GEP stk ht. and others CALL GPC (D, I, C, S, TW, WS, HTA, C, 1) END IF ***** ..\NEW\BPIP.FOR C Call subroutine to calculate a GEP stk ht. and others CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C, S, TW, WS, HTA, C, 1) END IF ***** ***** BPIP.FOR C1 = (I - 1) * MXTRS + J CALL WIDTH(ANG, I, J, C1, TW) W(C1) = TW ***** ..\NEW\BPIP.FOR C1 = (I - 1) * MXTRS + J CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, I, J, C1, TW) W(C1) = TW ***** ***** BPIP.FOR C2 = (II - 1) * MXTRS + JJ CALL WIDTH(ANG, II, JJ, C2, TW) W(C2) = TW ***** ..\NEW\BPIP.FOR C2 = (II - 1) * MXTRS + JJ CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, II, JJ, C2, TW) W(C2) = TW ***** ***** BPIP.FOR HT(C2) = TH(II,JJ) C R is 'L'; combinable if distance between tiers is < L C If yes, add tier number to TLIST and increment counter TNUM R = MIN(W(C1), HT(C1)) IF (DISTMN(C1, C2) .LT. R) THEN ***** ..\NEW\BPIP.FOR HT(C2) = TH(II,JJ) C R is 'L'; combinable if distance between tiers is < L C If yes, add tier number to TLIST and increment counter TNUM R = MIN( W(C1), HT(C1) ) IF (DISTMN(C1, C2) .LT. R) THEN ***** ***** BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (D, I, C1, S, TW, WS, HTA, TL1,2) GO TO 136 ***** ..\NEW\BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C1, S, TW, WS, HTA, TL1,2) GO TO 136 ***** ***** BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ..\NEW\BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ***** BPIP.FOR C IBET = 1, if at or within 5L DO 133 K = 1, ND(I, J) X11 = XC(C1, K) ***** ..\NEW\BPIP.FOR C IBET = 1, if at or within 5L DO K = 1, ND(I, J) X11 = XC(C1, K) ***** ***** BPIP.FOR Y12 = YC(C1, K1) DO 133 L = 1, ND(II,JJ) X21 = XC(C2, L) ***** ..\NEW\BPIP.FOR Y12 = YC(C1, K1) DO L = 1, ND(II,JJ) X21 = XC(C2, L) ***** ***** BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ..\NEW\BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ***** BPIP.FOR C perimeter of the GFS CALL CNRLIN(X11, Y11, X12, Y12, BET, DIST, X21, Y21) IF (DIST .LE. WS .AND. BET .GT. -.001) THEN ***** ..\NEW\BPIP.FOR C perimeter of the GFS CALL CNRLIN(XI,YI,X11,Y11,X12,Y12,BET, DIST, X21, Y21) IF (DIST .LE. WS .AND. BET .GT. -.001) THEN ***** ***** BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (D,I,C1,S,TW,WS, HTA, TL1, 2) GO TO 136 ***** ..\NEW\BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D,I,C1,S,TW,WS, HTA, TL1, 2) GO TO 136 ***** ***** BPIP.FOR END IF CALL CNRLIN(X21, Y21, X22, Y22, BET, DIST, X11, Y11) IF (DIST .LE. WS .AND. BET .GT. -.001) THEN ***** ..\NEW\BPIP.FOR END IF CALL CNRLIN(XI,YI,X21,Y21,X22,Y22,BET, DIST, X11, Y11) IF (DIST .LE. WS .AND. BET .GT. -.001) THEN ***** ***** BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ..\NEW\BPIP.FOR IF (IBET .EQ. 1) THEN CALL GPC (MB, MBT, MXTRS, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C1, S, TW, WS, HTA, TL1, 2) GO TO 136 ***** ***** BPIP.FOR END IF 133 CONTINUE 135 CONTINUE ***** ..\NEW\BPIP.FOR END IF END DO END DO 135 CONTINUE ***** ***** BPIP.FOR WRITE(12,297) C ***** ..\NEW\BPIP.FOR WRITE(12,297) C ***** ***** BPIP.FOR YPSTK = YS(S) * CSA - XS(S) * SNA XP(S) = XPSTK YP(S) = YPSTK DO 320 I = 1, NB ***** ..\NEW\BPIP.FOR YPSTK = YS(S) * CSA - XS(S) * SNA DO 320 I = 1, NB ***** ***** BPIP.FOR HTA = TH(I,J) CALL WIDTH (ANG, I, J, C, TW) WS = TW ***** ..\NEW\BPIP.FOR HTA = TH(I,J) CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, I, J, C, TW) WS = TW ***** ***** BPIP.FOR TLIST2(C,1) = C CALL MXBWH(D, I, S, C, TW, HTA, WS, CH, 1) END IF ***** ..\NEW\BPIP.FOR TLIST2(C,1) = C IG = 1 CALL MXBWH(MB, MXTRS, MBT, MSK, MD, DFLG, * DE, DHWE, DPBH, DPBW, BELEV, SB, * GEP, GEPBH, GEPBW, GEPIN, * MHWE, MXPBH, MXPBW, * MI, MJ, TNUM2, TLIST2, MTNUM, MTLIST, * D, I, S, C, TW, HTA, WS, CH, IG) END IF ***** ***** BPIP.FOR 300 CONTINUE DO 345 ISS = 1, NS DO 345 D = 1, NDIR DFLG(ISS, D) = 0 345 CONTINUE C ***** ..\NEW\BPIP.FOR 300 CONTINUE DO ISS = 1, NS DO D = 1, NDIR DFLG(ISS, D) = 0 END DO END DO C ***** ***** BPIP.FOR IF (NB .EQ. 1) THEN WRITE(14,*) 'Dominate combined buildings: None' ELSE ***** ..\NEW\BPIP.FOR IF (NB .EQ. 1) THEN WRITE(14,*) 'Dominant combined buildings: None' ELSE ***** ***** BPIP.FOR WRITE(*,*) ' Calculating group of tiers downwash values.' WRITE(14,*) 'Dominate combined buildings:' END IF ***** ..\NEW\BPIP.FOR WRITE(*,*) ' Calculating group of tiers downwash values.' WRITE(14,*) 'Dominant combined buildings:' END IF ***** ***** BPIP.FOR C1 = (I - 1) * MXTRS + J CALL WIDTH(ANG, I, J, C1, TW) W(C1) = TW ***** ..\NEW\BPIP.FOR C1 = (I - 1) * MXTRS + J CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, I, J, C1, TW) W(C1) = TW ***** ***** BPIP.FOR C2 = (II - 1) * MXTRS + JJ CALL WIDTH(ANG, II, JJ, C2, TW) W(C2) = TW ***** ..\NEW\BPIP.FOR C2 = (II - 1) * MXTRS + JJ CALL WIDTH (MB, MXTRS, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, II, JJ, C2, TW) W(C2) = TW ***** ***** BPIP.FOR IF (TNUM2(C) .GT. 1) THEN DO 400 S = 1, NS ***** ..\NEW\BPIP.FOR IF (TNUM2(C) .GT. 1) THEN IG = 2 DO 400 S = 1, NS ***** ***** BPIP.FOR C If so, calculate the PBW & PBH, save max values CALL MXBWH(D, I, S, C, TW, HTA, WS, CH, 2) END IF ***** ..\NEW\BPIP.FOR C If so, calculate the PBW & PBH, save max values IG = 2 CALL MXBWH(MB, MXTRS, MBT, MSK, MD, DFLG, * DE, DHWE, DPBH, DPBW, BELEV, SB, * GEP, GEPBH, GEPBW, GEPIN, * MHWE, MXPBH, MXPBW, * MI, MJ, TNUM2, TLIST2, MTNUM, MTLIST, * D, I, S, C, TW, HTA, WS, CH, IG) END IF ***** ***** BPIP.FOR IF (MTNUM(S,2) .LT. 2) THEN WRITE(14,*) ' No combined tiers affect this stack for ', + 'this direction.' C WRITE(IFILE, 431) S, D 431 FORMAT(1X,'S,D', 2I2,' NO COMBINED TIERS FOR THIS DIRCTN') ELSE ***** ..\NEW\BPIP.FOR IF (MTNUM(S,2) .LT. 2) THEN WRITE(14,*) ' No combined tiers affect this stack ', + 'for this direction.' C WRITE(IFILE, 431) S, D C 431 FORMAT(1X,'S,D', 2I2,' NO COMBINED TIERS FOR THIS DIRCTN') ELSE ***** ***** BPIP.FOR WRITE(14,2024) (MTLIST(S,M,2), M = 1, MTNUM(S,2)) 432 FORMAT(1X,'S,D',2I2, 2F6.2, I4, 2X, 10I3) ELSE ***** ..\NEW\BPIP.FOR WRITE(14,2024) (MTLIST(S,M,2), M = 1, MTNUM(S,2)) C WRITE(IFILE, 432) S, D, SB(S), BELEV(MI(S,2)), MTNUM (S,2), C + (MTLIST(S,M,2), M = 1, MTNUM(S,2)) C 432 FORMAT(1X,'S,D',2I2, 2F6.2, I4, 2X, 10I3) ELSE ***** ***** BPIP.FOR WRITE(12,297) DO 512 I = 1, 6 J = (I-1) * 6 + 1 ***** ..\NEW\BPIP.FOR WRITE(12,297) DO I = 1, 6 J = (I-1) * 6 + 1 ***** ***** BPIP.FOR K = I * 6 WRITE (12,293) STKN(S), (MXPBH(S,D) , D = J,K) 512 CONTINUE DO 514 I = 1, 6 J = (I-1) * 6 + 1 ***** ..\NEW\BPIP.FOR K = I * 6 WRITE (12,293) STKN(S), (MXPBH(S,D) , D = J,K) END DO DO I = 1, 6 J = (I-1) * 6 + 1 ***** ***** BPIP.FOR K = I * 6 WRITE (12,296) STKN(S), (MXPBW(S,D) , D = J,K) 514 CONTINUE 510 CONTINUE END IF ***** ..\NEW\BPIP.FOR K = I * 6 WRITE (12,296) STKN(S), (MXPBW(S,D) , D = J,K) END DO 510 CONTINUE END IF ***** ***** BPIP.FOR C ***** ..\NEW\BPIP.FOR C ***** ***** BPIP.FOR 1 FORMAT(1X,A78,/) 2 FORMAT(/3X,'The ',A2,' flag has been set for processing for an ', +'ISCST2 run.'/) 3 FORMAT(3X,'Inputs entered in ', A10,' will be converted to ', ***** ..\NEW\BPIP.FOR 1 FORMAT(1X,A78,/) 2 FORMAT(/3X,'The ',A2,' flag has been set for preparing downwash', + ' data for an ISCST run.'/) 3 FORMAT(3X,'Inputs entered in ', A10,' will be converted to ', ***** ***** BPIP.FOR 6 FORMAT(1X,'Number of buildings to be processed :',I4) 7 FORMAT(37X,'(',2F12.2,')') 8 FORMAT(' Factor to convert from input units to meters is:',F10.4) 9 FORMAT(/3X,'The ',A2,' flag has been set for processing for an', *' ISCLT2 run.'/) 11 FORMAT(3X,'The new local coordinates will be displayed in parent', ***** ..\NEW\BPIP.FOR 6 FORMAT(1X,'Number of buildings to be processed :',I4) C 7 FORMAT(37X,'(',2F12.2,')') C 8 FORMAT(' Factor to convert from input units to meters is:',F10.4) 9 FORMAT(/3X,'The ',A2,' flag has been set for preparing downwash', + ' data for an ISCLT run.'/) 11 FORMAT(3X,'The new local coordinates will be displayed in parent', ***** ***** BPIP.FOR 115 FORMAT(' Wind flow passing', I4,' degree direction.') 292 FORMAT(3(/1X, 8F6.2)) 293 FORMAT(5X,'SO BUILDHGT ', A8, 6F8.2) ***** ..\NEW\BPIP.FOR 115 FORMAT(' Wind flow passing', I4,' degree direction.') C292 FORMAT(3(/1X, 8F6.2)) 293 FORMAT(5X,'SO BUILDHGT ', A8, 6F8.2) ***** ***** BPIP.FOR 297 FORMAT(/) 411 FORMAT(/1X, A8) 461 FORMAT(30X,'BPIP (Dated: 95086)') 462 FORMAT(1X,'DATE : ',I2,'/',I2,'/',I2) 463 FORMAT(1X,'TIME : ',I2,':',I2,':',I2) ***** ..\NEW\BPIP.FOR 297 FORMAT(/) C411 FORMAT(/1X, A8) 461 FORMAT(30X,'BPIP (Dated: 04112)') 462 FORMAT(1X,'DATE : ',I2,'/',I2,'/',I4) 463 FORMAT(1X,'TIME : ',I2,':',I2,':',I2) ***** ***** BPIP.FOR * ' (Units: meters)'//) 1021 FORMAT(10X,'NOTE: The projected width values below are not always' * ,/10X,' the maximum width. They are the minimum value,' * ,/10X,' valid for the stack in question, to derive the' * ,/10X,' maximum GEP stack height.'/) 1022 FORMAT(' StkNo:', I3,' Stk Name:', A8,' Stk Ht:',F7.2, ***** ..\NEW\BPIP.FOR * ' (Units: meters)'//) C1021 FORMAT(10X,'NOTE: The projected width values below are not always' C * ,/10X,' the maximum width. They are the minimum value,' C * ,/10X,' valid for the stack in question, to derive the' C * ,/10X,' maximum GEP stack height.'/) 1022 FORMAT(' StkNo:', I3,' Stk Name:', A8,' Stk Ht:',F7.2, ***** ***** BPIP.FOR SUBROUTINE CNRLIN (X1, Y1, X2, Y2, BET, DIST, XKP, YKP) C calculate corner perpendicular to side distance, ***** ..\NEW\BPIP.FOR SUBROUTINE CNRLIN (XI,YI,X1, Y1, X2, Y2, BET, DIST, XKP, YKP) C calculate corner perpendicular to side distance, ***** ***** BPIP.FOR C corners. COMMON /INTRCP/ XI, YI IF ((X1 .NE. X2) .AND. (Y1 .NE. Y2)) THEN ***** ..\NEW\BPIP.FOR C corners. IMPLICIT NONE REAL A1, A2, BET, DIST, SM, X1, X2, XI, XKP, Y1, Y2, YI, YKP IF ((X1 .NE. X2) .AND. (Y1 .NE. Y2)) THEN ***** ***** BPIP.FOR C within 5L of side. REAL L5 IBET = 0 ***** ..\NEW\BPIP.FOR C within 5L of side. IMPLICIT NONE INTEGER IBET REAL D1, D2, DIST, DX1, DX2, L5, X1, X2, XSP, Y1, Y2, YI, YSP IBET = 0 ***** ***** BPIP.FOR END SUBROUTINE GPC (D, I, C, S, TW, WS, HTA, CH, IG) C calculate GEP values ***** ..\NEW\BPIP.FOR END SUBROUTINE GPC (MB, MBT, MT, MSK, BELEV, * SB, GEP,GEPBH,GEPBW,GEPIN, TNUM2, TLIST2, * GTNUM, GTLIST, GDIRS, MI, MJ, * D, I, C, S, TW, WS, HTA, CH, IG) C calculate GEP values ***** ***** BPIP.FOR INTEGER C, CH, D, S, GEPIN, TNUM2, TLIST2, GTNUM, GTLIST PARAMETER (MB = 8, MT = 4, MTS = 8, MBT = MB*MT, MSK = 14, * MD = 36, ML = 16) COMMON /ELEV/ BELEV(MB), SB(MSK) COMMON /GP/ GEP(MSK), GEPBH(MSK), GEPBW(MSK), * GEPIN(MSK,MBT,MBT,2) COMMON /TNM/ TNUM2(MBT), TLIST2(MBT,MBT) COMMON /GTNM/ GTNUM(MSK), GTLIST(MSK,MBT), GDIRS(MSK) COMMON /MIJ/ MI(MSK,2), MJ(MSK,2) ***** ..\NEW\BPIP.FOR IMPLICIT NONE INTEGER C, CH, D, GEPIN, GTLIST, GTNUM, * I, IG, M, MB, MBT, MSK, MT, MI, MJ, S, TNUM2, TLIST2 REAL BELEV, GDIRS, GEP, GEPBH, GEPBW, HTA, HWE, SB, TW, WS DIMENSION BELEV(MB), SB(MSK) DIMENSION GEP(MSK), GEPBH(MSK), GEPBW(MSK), * GEPIN(MSK,MBT,MBT,2) DIMENSION TNUM2(MBT), TLIST2(MBT,MBT) DIMENSION GTNUM(MSK), GTLIST(MSK,MBT), GDIRS(MSK) DIMENSION MI(MSK,2), MJ(MSK,2) ***** ***** BPIP.FOR C SUBROUTINE MXBWH(D, I, S, C, TW, HTA, WS, TL1, IG) C ******************************************************************** PARAMETER (MB = 8, MT = 4, MTS = 8, MBT = MB*MT , MSK = 14, * * MD = 36, ML = 16) * C ******************************************************************** C ***** ..\NEW\BPIP.FOR C SUBROUTINE MXBWH(MB, MT, MBT, MSK, MD, DFLG, * DE, DHWE, DPBH, DPBW, BELEV, SB, * GEP, GEPBH, GEPBW, GEPIN, * MHWE, MXPBH, MXPBW, * MI, MJ, TNUM2, TLIST2, MTNUM, MTLIST, * D, I, S, C, TW, HTA, WS, TL1, IG) C ***** ***** BPIP.FOR C REAL MHWE, MXPBH, MXPBW INTEGER C, D, DE, GEPIN, S, SS, TNUM2, TLIST2, TL1 COMMON /DE/ DE, DFLG(MSK, MD), DHWE(MSK), DPBH(MSK), DPBW(MSK) COMMON /ELEV/ BELEV(MB), SB(MSK) COMMON /GP/ GEP(MSK), GEPBH(MSK), GEPBW(MSK), + GEPIN(MSK,MBT,MBT,2) COMMON /MXB/ MHWE(MSK, MD), MXPBH(MSK, MD), MXPBW(MSK, MD) COMMON /MIJ/ MI(MSK,2), MJ(MSK,2) COMMON /TNM/ TNUM2(MBT), TLIST2(MBT,MBT) COMMON /MTNM/ MTNUM(MSK,2), MTLIST(MSK,MBT,2) C ***** ..\NEW\BPIP.FOR C IMPLICIT NONE INTEGER C, D, DE, DFLG, GEPIN, I, IG, * M, MB, MBT, MD, MFLG, MI, MJ, MSK, MT, MTLIST, MTNUM, * S, SS, TNUM2, TLIST2, TL1 REAL BELEV, DHWE, DPBH, DPBW, * GEP, GEPBH, GEPBW, HWE, HTA, * MHWE, MXPBH, MXPBW, * PBH, PBW, SB, TW, WS DIMENSION DFLG(MSK, MD), DHWE(MSK), DPBH(MSK), DPBW(MSK) DIMENSION BELEV(MB), SB(MSK) DIMENSION GEP(MSK), GEPBH(MSK), GEPBW(MSK), + GEPIN(MSK,MBT,MBT,2) DIMENSION MHWE(MSK, MD), MXPBH(MSK, MD), MXPBW(MSK, MD) DIMENSION MI(MSK,2), MJ(MSK,2) DIMENSION TNUM2(MBT), TLIST2(MBT,MBT) DIMENSION MTNUM(MSK,2), MTLIST(MSK,MBT,2) C ***** ***** BPIP.FOR PBH = HTA ***** ..\NEW\BPIP.FOR MFLG = 0 PBH = HTA ***** ***** BPIP.FOR DE = D DO 577 SS = 1, MSK DHWE(SS) = 0.0 DPBH(SS) = 0.0 DPBW(SS) = 0.0 MTNUM(SS,IG) = 0 577 DFLG(SS, D) = 0 END IF ***** ..\NEW\BPIP.FOR DE = D DO SS = 1, MSK DHWE(SS) = 0.0 DPBH(SS) = 0.0 DPBW(SS) = 0.0 MHWE(SS, D) = 0.00 MXPBH(SS, D) = 0.00 MXPBW(SS, D) = 0.00 MTNUM(SS,IG) = 0 DFLG(SS, D) = 0 END DO END IF ***** ***** BPIP.FOR MJ(S,IG) = C - (I-1)*MT DO 578 M = 1, MTNUM(S,IG) MTLIST(S,M,IG) = TLIST2(C,M) 578 CONTINUE MFLG = 0 ***** ..\NEW\BPIP.FOR MJ(S,IG) = C - (I-1)*MT DO M = 1, MTNUM(S,IG) MTLIST(S,M,IG) = TLIST2(C,M) END DO MFLG = 0 ***** ***** BPIP.FOR C Determine if any combined buildings exist for a particular sector C Save the combination producing the highest HWE for C the Summary Table ***** ..\NEW\BPIP.FOR C Determine if any combined buildings exist for a particular sector C Save the combination producing the highest HWE for C the Summary Table ***** ***** BPIP.FOR MJ(S,IG) = C - (I-1) * MT DO 579 M = 1, MTNUM(S,IG) MTLIST(S,M,IG) = TLIST2(C,M) 579 CONTINUE END IF ENDIF END IF ***** ..\NEW\BPIP.FOR MJ(S,IG) = C - (I-1) * MT DO M = 1, MTNUM(S,IG) MTLIST(S,M,IG) = TLIST2(C,M) END DO END IF END IF END IF ***** ***** BPIP.FOR C SUBROUTINE WIDTH (ANG, I, J, C, TW) C Calculate projected building width, TW INTEGER C PARAMETER (MB = 8, MT = 4, MTS = 8, MBT = MB*MT, MSK = 14, * MD = 36, ML = 16) COMMON /BLDGIN/ X(MB, MT, MTS), Y(MB, MT, MTS), ND(MB, MT) COMMON /BLDOUT/ XC(MBT, MTS), YC(MBT, MTS) COMMON /MXN/ XMAX(MBT), XMIN(MBT), YMAX(MBT), YMIN(MBT) CSA = COS(ANG) SNA = -SIN(ANG) DO 700 K = 1, ND(I,J) XC(C, K) = X(I, J, K) * CSA + Y(I, J, K) * SNA YC(C, K) = Y(I, J, K) * CSA - X(I, J, K) * SNA IF (K .EQ. 1) THEN ***** ..\NEW\BPIP.FOR C SUBROUTINE WIDTH (MB, MT, MTS, MBT, X, Y, ND, XC, YC, * XMAX, XMIN, YMAX, YMIN, ANG, I, J, C, TW) C Calculate projected building width, TW IMPLICIT NONE INTEGER C, I, J, K, MB, MBT, MT, MTS, ND REAL ANG, TW, XC, XMAX, XMIN, YC, YMAX, YMIN DOUBLE PRECISION X, Y, CSA, SNA DIMENSION X(MB, MT, MTS), Y(MB, MT, MTS), ND(MB, MT) DIMENSION XC(MBT, MTS), YC(MBT, MTS) DIMENSION XMAX(MBT), XMIN(MBT), YMAX(MBT), YMIN(MBT) CSA = DCOS(DBLE(ANG)) SNA = -DSIN(DBLE(ANG)) DO 700 K = 1, ND(I,J) XC(C, K) = SNGL(X(I, J, K) * CSA + Y(I, J, K) * SNA) YC(C, K) = SNGL(Y(I, J, K) * CSA - X(I, J, K) * SNA) IF (K .EQ. 1) THEN ***** ***** BPIP.FOR TW = XMAX(C) - XMIN(C) RETURN ***** ..\NEW\BPIP.FOR TW = XMAX(C) - XMIN(C) RETURN ***** ***** BPIP.FOR END ***** ..\NEW\BPIP.FOR END *****