C ********************************************************************** C * * C * SOFTWARE LICENSING * C * * C * This program is free software; you can redistribute * C * it and/or modify it under the terms of the GNU * C * General Public License as published by the Free * C * Software Foundation, either Version 2 of the * C * license, or (at your option) any later version. * C * * C * This program is distributed in the hope that it * C * will be useful, but without any warranty; without * C * even the implied warranty of merchantability or * C * fitness for a particular purpose. See the GNU * C * General Public License for more details. * C * * C * A copy of the GNU General Public License is * C * available at http://www.gnu.org/copyleft/gpl.html * C * or by writing to the Free Software Foundation, Inc.,* C * 59 Temple Place - Suite 330, Boston, MA 02111, USA. * C * * C ********************************************************************** SUBROUTINE FIRST C C VERSION(10/02/90) C INCLUDE 'comdeck' SAVE DIMENSION COM(80) C IF(NUMEBC.EQ.0) GO TO 140 C IF(OPTEBC(1:5).EQ.'DATA ') THEN !NO NEED TO HAVE THIS ANYMORE(NKIM 121798) REWIND IUT90 DO 100 M=1,100000 IFLAG=1 READ (IUT90,10,ERR=130) T2E READ (IUT90,10) (DEBDRY(N,2),N=1,NUMEBC) IF(THOUR.LT.T2E) GO TO 110 T1E=T2E DO 120 N=1,NUMEBC 120 DEBDRY(N,1)=DEBDRY(N,2) 100 CONTINUE 110 CONTINUE C END IF ! NO NEED TO HAVE THIS ANYMORE (NKIM 121798) 140 CONTINUE C IF (HYDTYPE.EQ.'EXTERNAL') GOTO 1135 C IF (NUMEBC.EQ.0) GOTO 135 REWIND IUT94 C DO 101 M=1,100000 IFLAG=2 READ (IUT94,10,ERR=130) T2TS DO 136 N=1,NUMEBC READ (IUT94,10) (DTBDRY(N,K,2),K=1,KBM1) READ (IUT94,10) (DSBDRY(N,K,2),K=1,KBM1) 136 CONTINUE IF(THOUR.LT.T2TS) GOTO 111 T1TS=T2TS DO 121 K=1,KBM1 DO 121 N=1,NUMEBC DTBDRY(N,K,1)=DTBDRY(N,K,2) DSBDRY(N,K,1)=DSBDRY(N,K,2) 121 CONTINUE 101 CONTINUE 111 CONTINUE C C DISSOLVED TRACER AT OPEN BOUNDARY C 1135 IF (TRACER.EQ.'INCLUDE'.AND.NUMEBCTR.GT.0) THEN REWIND (IUT501) DO 1010 M=1,100000 IFLAG=3 READ (IUT501,10,ERR=130) T2CONOB C DO 1020 N=1,NUMEBCTR READ (IUT501,10) (DCBDRY1(N,K,2),K=1,KBM1) 1020 CONTINUE C IF(THOUR.LT.T2CONOB) GOTO 1030 C T1CONOB=T2CONOB DO 1040 K=1,KBM1 DO 1040 N=1,NUMEBCTR DCBDRY1(N,K,1)=DCBDRY1(N,K,2) 1040 CONTINUE 1010 CONTINUE 1030 CONTINUE ENDIF C C SEDIMENT TRANSPORT AT OPEN BOUNDARY C IF (SEDTRAN.EQ.'INCLUDE'.AND.NUMEBCSE.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT502) DO 1110 M=1,100000 IFLAG=4 READ (IUT502,10,ERR=130) T2SEDOBM C DO 1120 N=1,NUMEBCSE READ (IUT502,10) (DCBDRY(1,N,K,2),K=1,KBM1) 1120 CONTINUE C IF(THOUR.LT.T2SEDOBM) GOTO 1130 C T1SEDOBM=T2SEDOBM DO 1140 K=1,KBM1 DO 1140 N=1,NUMEBCSE DCBDRY(1,N,K,1)=DCBDRY(1,N,K,2) 1140 CONTINUE 1110 CONTINUE 1130 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT503) DO 1150 M=1,100000 IFLAG=5 READ (IUT503,10,ERR=130) T2SEDOBS C IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF C DO 1160 N=1,NUMEBCSE READ (IUT503,10) (DCBDRY(KK,N,K,2),K=1,KBM1) 1160 CONTINUE C IF(THOUR.LT.T2SEDOBS) GOTO 1180 C T1SEDOBS=T2SEDOBS DO 1170 K=1,KBM1 DO 1170 N=1,NUMEBCSE DCBDRY(KK,N,K,1)=DCBDRY(KK,N,K,2) 1170 CONTINUE 1150 CONTINUE 1180 CONTINUE ENDIF ENDIF C C PARTICLE-BOUND TRACER AT OPEN BOUNDARY C IF (CHEMTRAN.EQ.'INCLUDE'.AND.NUMEBCCH.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT504) DO 1210 M=1,100000 IFLAG=6 READ (IUT504,10,ERR=130) T2CHMOBM C KK=1 C DO 1220 N=1,NUMEBCCH READ (IUT504,10) (DPBDRY(KK,N,K,2),K=1,KBM1) 1220 CONTINUE C IF(THOUR.LT.T2CHMOBM) GOTO 1230 C T1CHMOBM=T2CHMOBM DO 1240 K=1,KBM1 DO 1240 N=1,NUMEBCCH DPBDRY(KK,N,K,1)=DPBDRY(KK,N,K,2) 1240 CONTINUE 1210 CONTINUE 1230 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT505) DO 1250 M=1,100000 IFLAG=7 READ (IUT505,10,ERR=130) T2CHMOBS C IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF C DO 1260 N=1,NUMEBCCH READ (IUT505,10) (DPBDRY(KK,N,K,2),K=1,KBM1) 1260 CONTINUE C IF(THOUR.LT.T2CHMOBS) GOTO 1270 C T1CHMOBS=T2CHMOBS DO 1280 K=1,KBM1 DO 1280 N=1,NUMEBCCH DPBDRY(KK,N,K,1)=DPBDRY(KK,N,K,2) 1280 CONTINUE 1250 CONTINUE 1270 CONTINUE ENDIF ENDIF C 135 CONTINUE c***********FRICTION DUE TO SOLID OBJECT-RMareooli_April2015******** DO J=1,JM DO K=1,KBM1 DO I=1,IM DWALLU3D(I,J,K)=0.0 DWALLV3D(I,J,K)=0.0 ENDDO ENDDO ENDDO DO J=1,JM DO I=1,IM DWALLU2D(I,J)=0.0 DWALLV2D(I,J)=0.0 ENDDO ENDDO C********************** WETLAND VEGETATION-RMarsooli_Jan2015********* DO J=1,JM DO I=1,IM DO K=1,KBM1 DVEG3D(I,J,K)=0.0 IVEG3D(I,J,K)=0.0 ENDDO DVEG2D(I,J)=0.0 IVEG2D(I,J)=0.0 NVEG(I,J)=0.0 BVEG(I,J)=0.0 HVEG(I,J)=0.0 CDVEG(I,J)=0.0 WNDSH_VEG(I,J)=1.0 STIFF(I,J)=9999999999.0 !INITIALIZE AS RIGID STEMS ENDDO ENDDO IF(WETLAND.EQ.'INCLUDE') THEN READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(A8)') VEGCDM READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(A8)') VEGCDWAVE READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(F6.3)') CDINER READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(F6.3)') CDQ2 READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(F6.3)') CDQ2L READ(IUVEG,'(80A1)') (COM(I),I=1,80) READ(IUVEG,'(I8)') NUMVEG READ(IUVEG,'(80A1)') (COM(I),I=1,80) DO II=1,NUMVEG READ(IUVEG,199,IOSTAT=ISTATUS) I,J,TEMP_NVEG,TEMP_BVEG, . TEMP_HVEG,TEMP_CDVEG,TEMP_WNDSH,TEMP_STIFF IDXVEG(II)=I IDYVEG(II)=J NVEG(I,J)=TEMP_NVEG BVEG(I,J)=TEMP_BVEG HVEG(I,J)=TEMP_HVEG HVEGA(I,J)=HVEG(I,J) CDVEG(I,J)=TEMP_CDVEG CDVEGW(I,J)=TEMP_CDVEG WNDSH_VEG(I,J)=TEMP_WNDSH STIFF(I,J)=TEMP_STIFF*3.1416*BVEG(I,J)**4/64.0 !FOR CYLINDERICAL STEMS ENDDO 199 FORMAT(2I5,F10.2,4F10.4,E10.3) ENDIF C********************** WAVE-INDUCED FORCES-RMarsooli_August2015********* ORBVEL=0.0 !WAVE-INDUCED ORBITAL VELOCITY DO J=1,JM DO I=1,IM ttx0(I,J)=0. !WAVE created vertical turbulence surface stress tty0(I,J)=0. tpx0(I,J)=0. !WAVE created vertical pressure surface stress tpy0(I,J)=0. ENDDO ENDDO DO j=1,JM DO i=1,IM DO K=1,KBM1 Sxx(i,j,k)=0. !WAVE radiation stress Sxy(i,j,k)=0. Syy(i,j,k)=0. ust(i,j,k)=0. !Stokes drift vst(i,j,k)=0. ENDDO ENDDO ENDDO C********************************************************************* CNG04232008 ELEVATION POTENTIAL CELLS IF(NUMEPC.EQ.0) GO TO 6540 REWIND IUT65 DO 6500 M=1,100000 IFLAG=65 READ (IUT65,10,ERR=130) T2EPC READ (IUT65,10) (DEPCOR(N,2),N=1,NUMEPC) IF(THOUR.LT.T2EPC) GO TO 6510 T1EPC=T2EPC DO N=1,NUMEPC QEPCNUDF(N)=0.0 ! INITIALIZE IF (DEPCOR(N,2).NE.-99.) THEN DEPCOR(N,1)=DEPCOR(N,2) ELSE DEPCOR(N,1)=-99. ! FLAG FOR FREE SOLUTION ENDIF ENDDO 6500 CONTINUE 6510 CONTINUE 6540 CONTINUE C C-------- WAVE PARAMETERS BOUNDARY (hli, 03/19/04) ------------- C CNG02222007 IF (WAVEDYN.EQ.'DONMODEL'.OR.WAVEDYN.EQ.'SMBMODEL') THEN IF (WAVEDYN(1:3).EQ.'DON'.OR.WAVEDYN.EQ.'SMBMODEL') THEN C IF (NUMEBC.NE.0.AND.CREADWBC) THEN REWIND IUT195 C DO M=1,100000 IFLAG=16 READ (IUT195,ERR=130) T2WAVE READ (IUT195)(DWHBFLX(N,2),N=1,NUMEBC) READ (IUT195)(DWPBFLX(N,2),N=1,NUMEBC) READ (IUT195)(DWDBFLX(N,2),N=1,NUMEBC) IF(THOUR.LT.T2WAVE) GOTO 1235 T1WAVE=T2WAVE DO N=1,NUMEBC DWHBFLX(N,1)=DWHBFLX(N,2) DWPBFLX(N,1)=DWPBFLX(N,2) DWDBFLX(N,1)=DWDBFLX(N,2) ENDDO ENDDO ENDIF ENDIF 1235 CONTINUE C C RMrsooli, SEPTEMBER2015, MELLOR ET AL WAVE MODEL IF (WAVEDYN.EQ.'MELLOR') THEN IF(NUMWMBC.NE.0) THEN REWIND IUT195 C DO M=1,100000 IFLAG=16 READ (IUT195,ERR=130) T2WAVE READ (IUT195)(DWHBFLX(N,2),N=1,NUMWMBC) READ (IUT195)(DWPBFLX(N,2),N=1,NUMWMBC) READ (IUT195)(DWDBFLX(N,2),N=1,NUMWMBC) IF(THOUR.LT.T2WAVE) GOTO 1236 T1WAVE=T2WAVE DO N=1,NUMWMBC DWHBFLX(N,1)=DWHBFLX(N,2) DWPBFLX(N,1)=DWPBFLX(N,2) DWDBFLX(N,1)=DWDBFLX(N,2) ENDDO ENDDO ENDIF ENDIF 1236 CONTINUE C C RIVER DISCHARGE BOUNDARY C IF (HYDTYPE.EQ.'EXTERNAL') GOTO 210 C IF (NUMQBC.EQ.0) GOTO 210 C REWIND (IUT91) C DO 200 M=1,100000 IFLAG=8 READ (IUT91,10,ERR=130) T2Q READ (IUT91,10) (DQDIS(N,2),N=1,NUMQBC) READ (IUT91,10) (DTDIS(N,2),N=1,NUMQBC) READ (IUT91,10) (DSDIS(N,2),N=1,NUMQBC) C IF(THOUR.LT.T2Q) GO TO 210 T1Q=T2Q DO 220 N=1,NUMQBC DQDIS(N,1)=DQDIS(N,2) DTDIS(N,1)=DTDIS(N,2) DSDIS(N,1)=DSDIS(N,2) 220 CONTINUE 200 CONTINUE 210 CONTINUE C C DISSOLVED TRACER AT RIVER DISCHARGE BOUNDARY C IF (TRACER.EQ.'INCLUDE'.AND.NUMQBCTR.GT.0) THEN REWIND (IUT601) DO 1275 M=1,100000 IFLAG=9 READ (IUT601,10,ERR=130) T2CON READ (IUT601,10) (DCDIS1(N,2),N=1,NUMQBCTR) C IF(THOUR.LT.T2CON) GO TO 1285 T1CON=T2CON C DO 1295 N=1,NUMQBCTR DCDIS1(N,1)=DCDIS1(N,2) 1295 CONTINUE 1275 CONTINUE 1285 CONTINUE ENDIF C C SEDIMENT TRANSPORT AT RIVER DISCHARGE BOUNDARY C IF (SEDTRAN.EQ.'INCLUDE'.AND.NUMQBCSE.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT602) DO 1300 M=1,100000 IFLAG=10 READ (IUT602,10,ERR=130) T2SEDM KK=1 READ (IUT602,10) (DCDIS(KK,N,2),N=1,NUMQBCSE) IF(THOUR.LT.T2SEDM) GO TO 1310 T1SEDM=T2SEDM C DO 1320 N=1,NUMQBCSE DCDIS(KK,N,1)=DCDIS(KK,N,2) 1320 CONTINUE 1300 CONTINUE 1310 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT603) DO 1330 M=1,100000 IFLAG=11 READ (IUT603,10,ERR=130) T2SEDS IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF READ (IUT603,10) (DCDIS(KK,N,2),N=1,NUMQBCSE) IF(THOUR.LT.T2SEDS) GO TO 1340 T1SEDS=T2SEDS C DO 1350 N=1,NUMQBCSE DCDIS(KK,N,1)=DCDIS(KK,N,2) 1350 CONTINUE 1330 CONTINUE 1340 CONTINUE ENDIF ENDIF C C PARTICLE-BOUND TRACER AT RIVER DISCHARGE BOUNDARY C IF (CHEMTRAN.EQ.'INCLUDE'.AND.NUMQBCCH.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT604) DO 1400 M=1,100000 IFLAG=12 READ (IUT604,10,ERR=130) T2CHMM KK=1 READ (IUT604,10) (DPDIS(KK,N,2),N=1,NUMQBCCH) IF(THOUR.LT.T2CHMM) GO TO 1410 T1CHMM=T2CHMM C DO 1420 N=1,NUMQBCCH DPDIS(KK,N,1)=DPDIS(KK,N,2) 1420 CONTINUE 1400 CONTINUE 1410 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT605) DO 1430 M=1,100000 IFLAG=13 READ (IUT605,10,ERR=130) T2CHMS IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF READ (IUT605,10) (DPDIS(KK,N,2),N=1,NUMQBCCH) IF(THOUR.LT.T2CHMS) GO TO 1440 T1CHMS=T2CHMS C DO 1450 N=1,NUMQBCCH DPDIS(KK,N,1)=DPDIS(KK,N,2) 1450 CONTINUE 1430 CONTINUE 1440 CONTINUE ENDIF ENDIF C c add 'DIFFUSER IN LOOP' to the codes, referring to TAMPA BAY codes c in /power6/wrai0010/MODEL/CODES/TRACER (hli, 09/28/00) C C ************************************************************ C DIFFUSER BOUNDARY c IF (HYDTYPE.EQ.'EXTERNAL') GOTO 330 C(flh,09/11/01) IF(NUMDBC1.EQ.0) GO TO 330 IF(NUMDBC1.EQ.0) GO TO 1510 REWIND IUT92 C DO M=1,100000 IFLAG=14 READ (IUT92,10,ERR=130) T2D READ (IUT92,10) (DQDIFF(N,2),N=1,NUMDBC1) READ (IUT92,10) (DTDIFF(N,2),N=1,NUMDBC1) READ (IUT92,10) (DSDIFF(N,2),N=1,NUMDBC1) IF(THOUR.LT.T2D) GO TO 330 T1D=T2D DO N=1,NUMDBC1 DQDIFF(N,1)=DQDIFF(N,2) DTDIFF(N,1)=DTDIFF(N,2) DSDIFF(N,1)=DSDIFF(N,2) ENDDO ENDDO C 330 CONTINUE C C DISSOLVED TRACER AT DIFFUSER C IF (TRACER.NE.'INCLUDE'.OR.NUMDBCTR1.EQ.0) GO TO 1510 REWIND IUT98 C DO M=1,100000 IFLAG=15 READ (IUT98,10,ERR=130) T2DCON READ (IUT98,10) (DCDIFF1(N,2),N=1,NUMDBCTR1) C IF(THOUR.LT.T2DCON) GO TO 1510 C T1DCON=T2DCON C DO N=1,NUMDBCTR1 DCDIFF1(N,1)=DCDIFF1(N,2) ENDDO ENDDO 1510 CONTINUE c C DIFFUSER IN LOOP BOUNDARY c IF(NUMDBC2.EQ.0) GO TO 1511 REWIND IUT96 C C DO M=1,100000 IFLAG=144 READ (IUT96,10,ERR=130) T2D2 READ (IUT96,10) (DQDIFF(N,2),N=NUMDBC1+1,NUMDBC) READ (IUT96,10) (DTDIFF(N,2),N=NUMDBC1+1,NUMDBC) READ (IUT96,10) (DSDIFF(N,2),N=NUMDBC1+1,NUMDBC) IF(THOUR.LT.T2D2) GO TO 311 T1D2=T2D2 DO N=NUMDBC1+1,NUMDBC DQDIFF(N,1)=DQDIFF(N,2) DTDIFF(N,1)=DTDIFF(N,2) DSDIFF(N,1)=DSDIFF(N,2) ENDDO ENDDO 311 CONTINUE C C DISSOLVED TRACER AT DIFFUSER IN LOOPS c GO TO 1511 ! DO NOT USE THIS FOR NOW IF (TRACER.NE.'INCLUDE'.OR.NUMDBCTR2.EQ.0) GO TO 1511 REWIND IUT99 DO M=1,100000 IFLAG=150 READ (IUT99,10,ERR=130) T2D2CON READ (IUT99,10) (DCDIFF1(N,2),N=NUMDBCTR1+1,NUMDBCTR) C IF(THOUR.LT.T2D2CON) GO TO 1511 C T1D2CON=T2D2CON C DO N=NUMDBCTR1+1,NUMDBCTR DCDIFF1(N,1)=DCDIFF1(N,2) ENDDO ENDDO 1511 CONTINUE c C end of adding DIFFUSER IN LOOP (hli, 09/28/00) C C POINT SOURCE LOADS: DISSOLVED TRACER C IF (TRACER.EQ.'INCLUDE'.AND.NUMPSTR.GT.0) THEN REWIND (IUT701) DO 4275 M=1,100000 IFLAG=91 READ (IUT701,10,ERR=130) T2PSTR READ (IUT701,10) (DCPSTR(N,2),N=1,NUMPSTR) C IF(THOUR.LT.T2PSTR) GO TO 4285 C T1PSTR=T2PSTR C DO 4295 N=1,NUMPSTR DCPSTR(N,1)=DCPSTR(N,2) 4295 CONTINUE 4275 CONTINUE 4285 CONTINUE ENDIF C C SEDIMENT LOADS AT DIFFUSER ***** Quamrul QA 5/12/99 C IF (SEDTRAN.EQ.'INCLUDE'.AND.NUMDBCSE.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT702) DO 7300 M=1,100000 IFLAG=702 READ (IUT702,10,ERR=730) T2SEDDM KK=1 READ (IUT702,10) (DCSDIFF(KK,N,2),N=1,NUMDBCSE) IF(THOUR.LT.T2SEDDM) GO TO 7310 T1SEDDM=T2SEDDM C DO 7320 N=1,NUMDBCSE DCSDIFF(KK,N,1)=DCSDIFF(KK,N,2) 7320 CONTINUE 7300 CONTINUE 7310 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT703) DO 7330 M=1,100000 IFLAG=703 READ (IUT703,10,ERR=730) T2SEDDS IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF READ (IUT703,10) (DCSDIFF(KK,N,2),N=1,NUMDBCSE) IF(THOUR.LT.T2SEDDS) GO TO 7340 T1SEDDS=T2SEDDS C DO 7350 N=1,NUMDBCSE DCSDIFF(KK,N,1)=DCSDIFF(KK,N,2) 7350 CONTINUE 7330 CONTINUE 7340 CONTINUE ENDIF ENDIF C C PARTICLE-BOUND TRACER AT DIFFUSER BOUNDARY By Quamrul QA 5/13/99 C IF (CHEMTRAN.EQ.'INCLUDE'.AND.NUMDBCCH.GT.0) THEN IF (SEDTYPE.EQ.'MUD '.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT704) DO 7400 M=1,100000 IFLAG=704 READ (IUT704,10,ERR=130) T2CHMDM KK=1 READ (IUT704,10) (DPDIFF(KK,N,2),N=1,NUMDBCCH) IF(THOUR.LT.T2CHMDM) GO TO 7410 T1CHMDM=T2CHMDM C DO 7420 N=1,NUMDBCCH DPDIFF(KK,N,1)=DPDIFF(KK,N,2) 7420 CONTINUE 7400 CONTINUE 7410 CONTINUE ENDIF C IF (SEDTYPE.EQ.'SAND'.OR.SEDTYPE.EQ.'BOTH') THEN REWIND (IUT705) DO 7430 M=1,100000 IFLAG=705 READ (IUT705,10,ERR=130) T2CHMDS IF (SEDTYPE.EQ.'SAND') THEN KK=1 ELSE KK=2 ENDIF READ (IUT705,10) (DPDIFF(KK,N,2),N=1,NUMDBCCH) IF(THOUR.LT.T2CHMDS) GO TO 7440 T1CHMDS=T2CHMDS C DO 7450 N=1,NUMDBCCH DPDIFF(KK,N,1)=DPDIFF(KK,N,2) 7450 CONTINUE 7430 CONTINUE 7440 CONTINUE ENDIF ENDIF C C IF(OPTMBC(1:8).EQ.'AVERAGED') THEN REWIND IUT93 DO 400 M=1,100000 IFLAG=93 READ (IUT93,10,ERR=130) T2M READ (IUT93,10) DHFLUX(2),DTX(2),DTY(2), + DWSX(2),DWSY(2),DWDS(2),DWDD(2),DQPREC(2),DQEVAP(2) IF(THOUR.LT.T2M) GO TO 410 T1M=T2M DQPREC(1)=DQPREC(2) DQEVAP(1)=DQEVAP(2) DHFLUX(1)=DHFLUX(2) DTX (1)=DTX (2) DTY (1)=DTY (2) DWSX (1)=DWSX (2) DWSY (1)=DWSY (2) DWDS (1)=DWDS (2) DWDD (1)=DWDD (2) 400 CONTINUE 410 CONTINUE C MOVE SYNOPTIC DOWN chli ELSE IF(OPTMBC(1:8).EQ.'SYNOPTIC') THEN ! JI CC REWIND IUT93 chli REWIND IUT192 chli DO 500 M=1,100000 chli IFLAG=92 *Khan 072898 CC READ (IUT93,10,ERR=130) T2M CC READ (IUT93,10) DQPREC(2),DQEVAP(2),DHFLUX(2) chli READ (IUT192,ERR=130) T2M chli READ (IUT192) ((DHFLX2D(I,J,2),I=1,IM),J=1,JM) *Khan 072898 chli IF(THOUR.LT.T2M) GO TO 510 chli T1M=T2M *Khan 072898 CC DQPREC(1)=DQPREC(2) CC DQEVAP(1)=DQEVAP(2) CC DHFLUX(1)=DHFLUX(2) chli DO 511 J=1,JM ! n.kim 7.7.98 chli DO 511 I=1,IM chli DHFLX2D(I,J,1)=DHFLX2D(I,J,2) chli 511 CONTINUE *Khan 072898 chli 500 CONTINUE chli 510 CONTINUE chli C------ WIND STRESS ---------------------------------------- chli REWIND IUT95 chli DO 520 M=1,100000 chli IFLAG=95 chli READ (IUT95,ERR=130) T2W chli READ (IUT95) ((DTX2D(I,J,2),DTY2D(I,J,2),DPATM(I,J,2), chli + I=1,IM),J=1,JM) chli IF(THOUR.LT.T2W) GO TO 530 chli T1W=T2W chli DO 540 J=1,JM chli DO 540 I=1,IM chli DPATM(I,J,1)=DPATM(I,J,2) chli DTX2D(I,J,1)=DTX2D(I,J,2) chli 540 DTY2D(I,J,1)=DTY2D(I,J,2) chli 520 CONTINUE chli 530 CONTINUE chli cqa ELSE IF (OPTMBC(1:8).EQ.'HEATFLUX') THEN C C MODIFIED BY QUAMRUL QA ON 3/10/99 *************************************** c Add three new options (SYNOPANB, SYNOPLNP and SYNOPRNM) c (hli,04/24/02) C else If (OPTMBC(1:8).EQ.'LANDPFLX'.OR. * OPTMBC(1:8).EQ.'RANDMFLX'.OR. * OPTMBC(1:8).EQ.'AANDBFLX'.OR. * OPTMBC(1:8).EQ.'SYNOPANB'.OR. * OPTMBC(1:8).EQ.'SYNOPLNP'.OR. * OPTMBC(1:8).EQ.'SYNOPRNM') Then cqa REWIND IUT93 DO 150 M = 1, 100000 READ (IUT93,810,ERR=130) T2M READ (IUT93,810) DAIRTM(2), DRELHU(2), * DBAROP(2), DSWOBS(2), DTX(2), DTY(2), DWSX(2), DWSY(2), * CLOUD(2), EXTCOEF(2), DQPREC(2), DQEVAP(2) 810 format(12e14.7) C IF (THOUR.LT.T2M) GO TO 160 T1M = T2M DQPREC(1) = DQPREC(2) DQEVAP(1) = DQEVAP(2) DAIRTM(1) = DAIRTM(2) DRELHU(1) = DRELHU(2) DBAROP(1) = DBAROP(2) DSWOBS(1) = DSWOBS(2) C MODIFIED BY QUAMRUL QA ON 5/3/96 ******************************************* CLOUD(1) = CLOUD(2) EXTCOEF(1) = EXTCOEF(2) DTX(1) = DTX(2) DTY(1) = DTY(2) DWSX(1) = DWSX(2) DWSY(1) = DWSY(2) DWDS (1)=DWDS (2) DWDD (1)=DWDD (2) 150 CONTINUE 160 CONTINUE c------ VARYING EXTINCTION COEFFICIENT ---------------------- c IF(OPTEXTC.EQ.'VARI') THEN REWIND IUT194 DO M=1,100000 IFLAG=194 READ (IUT194,ERR=130) T2EX READ (IUT194)((DEXTC(I,J,2),I=1,IM),J=1,JM) IF(THOUR.LT.T2EX) GO TO 1530 T1EX=T2EX DO J=1,JM DO I=1,IM DEXTC(I,J,1)=DEXTC(I,J,2) ENDDO ENDDO ENDDO 1530 CONTINUE ENDIF c ENDIF c IF ( OPTMBC(1:8).EQ.'SYNOPANB'.OR. & OPTMBC(1:8).EQ.'SYNOPLNP'.OR. & OPTMBC(1:8).EQ.'SYNOPRNM'.OR. & OPTMBC(1:8).EQ.'SYNOPTIC') Then IF(OPTMBC(1:8).EQ.'SYNOPTIC') Then REWIND IUT192 DO M=1,100000 IFLAG=92 READ (IUT192,ERR=130) T2M READ (IUT192) ((DHFLX2D(I,J,2),I=1,IM),J=1,JM) IF(THOUR.LT.T2M) GOTO 510 T1M=T2M DO J=1,JM ! n.kim 7.7.98 DO I=1,IM DHFLX2D(I,J,1)=DHFLX2D(I,J,2) ENDDO ENDDO ENDDO 510 CONTINUE ENDIF REWIND IUT95 DO M=1,100000 IFLAG=18 READ (IUT95,ERR=130) T2W READ (IUT95) ((DTX2D(I,J,2),DTY2D(I,J,2),DPATM(I,J,2), . DWSX2D(I,J,2),DWSY2D(I,J,2), ! NG04032008 . I=1,IM),J=1,JM) IF(THOUR.LT.T2W) GO TO 630 T1W=T2W DO J=1,JM ! NG04102008 DO I=1,IM DPATM(I,J,1)=DPATM(I,J,2) DTX2D(I,J,1)=DTX2D(I,J,2) DTY2D(I,J,1)=DTY2D(I,J,2) DWSX2D(I,J,1)=DWSX2D(I,J,2) ! NG04032008 DWSY2D(I,J,1)=DWSY2D(I,J,2) ! NG04032008 ENDDO ENDDO ENDDO 630 CONTINUE c ENDIF c CNG04092008 BELOW NOT NEEDED ANY MORE. USE WSX2D, WSY2D FOR WINDS FROM NOW ON. CNG04092008 IF (WAVEDYN(1:3).EQ.'DON'.OR.WAVEDYN.EQ.'SMBMODEL') THEN CNG04092008 REWIND IUT193 CNG04092008 DO M=1,100000 CNG04092008 IFLAG=193 CNG04092008 READ (IUT193,ERR=130) T2WV CNG04092008 READ (IUT193) ((WU2(I,J),WV2(I,J),I=1,IM),J=1,JM) CNG04092008 IF(THOUR.LT.T2WV) GO TO 5311 CNG04092008 T1WV=T2WV CNG04092008 DO J=1,JM CNG04092008 DO I=1,IM CNG04092008 WU1(I,J)=WU2(I,J) CNG04092008 WV1(I,J)=WV2(I,J) CNG04092008 ENDDO CNG04092008 ENDDO CNG04092008 ENDDO CNG04092008 5311 CONTINUE CNG04092008 ENDIF csvv080326 inserted C READ 2D WIND AND HEAT FLUX PARAMETERS IF ( OPTMBC(1:8).EQ.'2DMETANB'.OR. & OPTMBC(1:8).EQ.'2DMETLNP'.OR. & OPTMBC(1:8).EQ.'2DMETRNM') Then REWIND IUT103 DO 621 M=1,100000 IFLAG=103 READ (IUT103,ERR=130) T2M write(IUPRT,*)T2M READ (IUT103) . ((DWSX2D(I,J,2),DWSY2D(I,J,2),DSWOBS2D(I,J,2), * DAIRTM2D(I,J,2),DRELHU2D(I,J,2), * DPATM(I,J,2), ! NG04092008 DBAROP2D(I,J,2), * DCLD2D(I,J,2),DEXTC2D(I,J,2),I=1,IM),J=1,JM) IF(THOUR.LT.T2M) GO TO 631 T1M=T2M DO 641 J=1,JM DO 641 I=1,IM DAIRTM2D(I,J,1) = DAIRTM2D(I,J,2) DRELHU2D(I,J,1) = DRELHU2D(I,J,2) DPATM(I,J,1) = DPATM(I,J,2) ! NG04092008 DBAROP2D(I,J,1) = DBAROP2D(I,J,2) DSWOBS2D(I,J,1) = DSWOBS2D(I,J,2) DWSX2D(I,J,1) = DWSX2D(I,J,2) DWSY2D(I,J,1) = DWSY2D(I,J,2) DCLD2D(I,J,1) = DCLD2D(I,J,2) 641 DEXTC2D(I,J,1) = DEXTC2D(I,J,2) 621 CONTINUE 631 CONTINUE END IF C COARE ALGORITHM_RMarsooli_May2015 IF ( OPTMBC(1:5).EQ.'COARE') Then IF(NCOARE.EQ.103) THEN REWIND IUT103 DO 622 M=1,100000 IFLAG=103 READ (IUT103,ERR=130) T2M write(IUPRT,*)T2M READ (IUT103) . ((DWSX2D(I,J,2),DWSY2D(I,J,2),DSWOBS2D(I,J,2), * DAIRTM2D(I,J,2),DRELHU2D(I,J,2), * DPATM(I,J,2), * DCLD2D(I,J,2),DEXTC2D(I,J,2),I=1,IM),J=1,JM) IF(THOUR.LT.T2M) GO TO 632 T1M=T2M DO 642 J=1,JM DO 642 I=1,IM DAIRTM2D(I,J,1) = DAIRTM2D(I,J,2) DRELHU2D(I,J,1) = DRELHU2D(I,J,2) DPATM(I,J,1) = DPATM(I,J,2) DSWOBS2D(I,J,1) = DSWOBS2D(I,J,2) DWSX2D(I,J,1) = DWSX2D(I,J,2) DWSY2D(I,J,1) = DWSY2D(I,J,2) DCLD2D(I,J,1) = DCLD2D(I,J,2) 642 DEXTC2D(I,J,1) = DEXTC2D(I,J,2) 622 CONTINUE 632 CONTINUE ELSE REWIND IUT93 DO 151 M = 1, 100000 READ (IUT93,'(E14.7)',ERR=130) T2M READ(IUT93,'(12E14.7)') DWDS(2),DWDD(2),DWSX(2),DWSY(2), . DSWOBS(2),DAIRTM(2),DRELHU(2),DBAROP(2),CLOUD(2), . EXTCOEF(2),DQPREC(2), DQEVAP(2) IF (THOUR.LT.T2M) GO TO 161 T1M = T2M DWDS (1) = DWDS (2) DWDD (1) = DWDD (2) DWSX (1) = DWSX (2) DWSY (1) = DWSY (2) DSWOBS (1) = DSWOBS (2) DAIRTM (1) = DAIRTM (2) DRELHU (1) = DRELHU (2) DBAROP (1) = DBAROP (2) CLOUD (1) = CLOUD (2) EXTCOEF(1) = EXTCOEF(2) DQPREC (1) = DQPREC (2) DQEVAP (1) = DQEVAP (2) 151 CONTINUE 161 CONTINUE END IF ENDIF CNG 2011 FOR VARIABLE ICE THICKNESS AND AREA. START... IF (ICEFRICTION.EQ.3) THEN REWIND IUT196 DO 6621 M=1,100000 IFLAG=196 READ (IUT196,ERR=130) T2I write(IUPRT,*)T2I READ (IUT196) ((DAREAICE(I,J,2),DTHICKICE(I,J,2) . ,I=1,IM),J=1,JM) IF(THOUR.LT.T2I) GO TO 6631 T1I=T2I DO 6641 J=1,JM DO 6641 I=1,IM DAREAICE(I,J,1) = DAREAICE(I,J,2) 6641 DTHICKICE(I,J,1) = DTHICKICE(I,J,2) 6621 CONTINUE 6631 CONTINUE END IF CNG 2011 FOR VARIABLE ICE THICKNESS AND AREA. ...END CNG09022014 For synop_pet, if it exists... IF(CREADPET) THEN REWIND IUT104 DO 721 M=1,100000 IFLAG=104 READ (IUT104,ERR=130) T2P write(IUPRT,*)T2P READ(IUT104) ((DQPREC2D(I,J,2),DQEVAP2D(I,J,2),I=1,IM),J=1,JM) IF(THOUR.LT.T2P) GO TO 731 T1P=T2P DO 741 J=1,JM DO 741 I=1,IM DQPREC2D(I,J,1) = DQPREC2D(I,J,2) ! NG2014 Use data 741 DQEVAP2D(I,J,1) = DQEVAP2D(I,J,2) ! NG2014 Use data 721 CONTINUE 731 CONTINUE END IF CNG09022014 ...For synop_pet, if it exists. c chli C C FOR WIND WAVE INPUT C IF (WAVEDYN.EQ.'EXTERNAL') THEN REWIND (111) DO 8010 M=1,100000 READ (111,ERR=8020) T2WAVE READ (111) ((DWVHT(I,J,2),I=1,IM),J=1,JM) READ (111) ((DWVPD(I,J,2),I=1,IM),J=1,JM) READ (111) ((DWVDR(I,J,2),I=1,IM),J=1,JM) C IF (THOUR.LT.T2WAVE) GO TO 8020 C T1WAVE=T2WAVE C DO 8030 J=1,JM DO 8030 I=1,IM DWVHT(I,J,1)=DWVHT(I,J,2) DWVPD(I,J,1)=DWVPD(I,J,2) DWVDR(I,J,1)=DWVDR(I,J,2) 8030 CONTINUE 8010 CONTINUE 8020 CONTINUE ENDIF C RETURN C 130 WRITE(6,20) IFLAG 20 FORMAT(//' THERE IS INSUFFICIENT TEMPORAL DATA FOR THIS RUN'/, . ' REVISE INPUT DECK AND RESUBMIT ' + // 'IFLAG =',I4) C 730 WRITE(6,70) IFLAG 70 FORMAT(//' THERE IS INSUFFICIENT TEMPORAL DATA FOR THIS RUN'/, . ' REVISE INPUT DECK AND RESUBMIT ' + // 'IFLAG =',I4) 10 FORMAT(8E14.7) STOP END