C---------------------------------------------------------------------------- C C MODULE PREP C C---------------------------------------------------------------------------- C current for ADCIRC v46.44 10/07/2006 C C Version 1.1 5/04/99 vjp c jjw fixes 053100 C Revisions by rl 10/12/01, MEB 3/03, rl 3/03, rl 5/21/03, rl 5/18/04, C vp 11/27/03 (by rl) C Revisions by MEB 4/04 C jgf Created PREP11, rewrote PREP20 for ADCIRC v45.12 02/24/2006 C jgf Created PREP13 for ADCRIC v46.00 C vjp PREP13 updates for ADCIRC v46.44 C vjp PREP67_68 localization updates for ADCIRC v46.44 C vjp added Relocalize for relocalizing fort.13 and fort.15 C C---------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 1 0 C--------------------------------------------------------------------------- C C jgf46.28 from jgf45.16 This subroutine will break up the full C domain initial concentration file into subdomains. The fort.10 C file may contain initial concentration for either 2D or 3D ADCIRC C runs. C C--------------------------------------------------------------------------- SUBROUTINE PREP10() C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J INTEGER iproc ! subdomain index CHARACTER*80 header1, header2 ! header comments in unit 10 files CHARACTER*80 nvn_nvp ! string representing nfen, np REAL(SZ) nvn ! number of vertical nodes from unit 10 file REAL(SZ) nvp ! number of horizontal nodes from unit 10 file INTEGER nhnn ! horizontal nodes counter INTEGER nvnn ! vertical nodes counter INTEGER sdu(nproc) ! subdomain unit numbers for unit 10 files REAL(SZ), ALLOCATABLE :: fdData2D(:) !(MNP) full domain data REAL(SZ), ALLOCATABLE :: fdData3D(:,:) !(MNP,NFEN) full domain data REAL(SZ), ALLOCATABLE :: sdData2D(:) !(MNP) subdomain data REAL(SZ), ALLOCATABLE :: sdData3D(:,:) !(MNP,NFEN) subdomain data LOGICAL success ! .true. if all files opened successfully CALL OpenPrepFiles(10, 'initial concentration ', & 1, nproc, sdu, success) IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 10 files not preprocessed.' RETURN ! note early return ENDIF C C Read header information from full domain unit 10 file READ(10,80) header1 READ(10,80) header2 C C Transcribe header information. DO iproc = 1, nproc WRITE(sdu(iproc),80) header1 WRITE(sdu(iproc),80) header2 ENDDO C C Check node number data for consistency (paranoia). READ(10,80) nvn_nvp READ(nvn_nvp,*) nvn, nvp IF ( nvn .ne. nfen .or. nvp .ne. nnodg ) then WRITE(*,*) 'ERROR: NVN or NVP not consistent with input data.' WRITE(*,*) 'NVN=',nvn,' although NFEN=',nfen WRITE(*,*) 'NVP=',nvp,' although NNODG=',nnodg ENDIF C C Decompose concentration data C IF (C2D_PTrans) THEN c read in the full domain data ALLOCATE ( fdData2D(MNP) ) nbytes = 8*mnp call memory_alloc(nbytes) DO i=1, NNODG READ(10,*) nhnn, fdData2D(nhnn) ENDDO c write out subdomain data ALLOCATE ( sdData2D(MNP) ) nbytes = 8*mnp call memory_alloc(nbytes) DO iproc = 1, nproc WRITE(sdu(iproc),*) nnodp(iproc) DO i=1, nnodp(iproc) sdData2D(i) = fdData2D(IMAP_NOD_LG(i,iproc)) WRITE(sdu(iproc),*) i, sdData2D(i) ENDDO ENDDO DEALLOCATE ( fdData2D, sdData2D ) nbytes = 16*mnp call memory_dealloc(nbytes) ENDIF C IF (C3D_PTrans) THEN c read in the full domain data ALLOCATE ( fdData3D(MNP,NFEN) ) nbytes = 8*mnp*nfen call memory_alloc(nbytes) DO i=1, NNODG DO j=1, nfen READ(10,*) nhnn, nvnn, fdData3D(nhnn,nvnn) ENDDO ENDDO c write out subdomain data ALLOCATE ( sdData3D(MNP,NFEN) ) nbytes = 8*mnp*nfen call memory_alloc(nbytes) DO iproc = 1, nproc WRITE(sdu(iproc),*) nfen, nnodp(iproc) DO i=1, nnodp(iproc) DO j=1, nfen sdData3D(i,j) = fdData3D(IMAP_NOD_LG(i,iproc),j) WRITE(sdu(iproc),*) i, j, sdData3D(i,j) ENDDO ENDDO ENDDO DEALLOCATE ( fdData3D, sdData3D ) nbytes = 16*mnp*nfen call memory_dealloc(nbytes) ENDIF C C Close full domain file and all subdomain files CLOSE(10) DO iproc=1, nproc CLOSE(sdu(iproc)) ENDDO C 80 FORMAT(A80) C call memory_status() RETURN C--------------------------------------------------------------------------- END SUBROUTINE PREP10 C--------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 1 1 C--------------------------------------------------------------------------- C C jgf45.12 This subroutine will break up the full domain initial C density forcing file into subdomains. The fort.11 file may C contain initial density, temperature, and/or salinity depending on C the value of IDEN in the fort.15 file. C C jgf45.12 This subroutine is designed to work for baroclinic 3D C runs only, not 2D runs. C C WJP 03.11.2018 made to work for 2D runs too C C--------------------------------------------------------------------------- SUBROUTINE PREP11() C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage use presizes, only: IDEN IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,eof,K INTEGER iproc ! subdomain index CHARACTER*80 header1, header2 ! header comments in unit 11 files CHARACTER*80 nvn_nvp CHARACTER*120 Dummy ! string representing nfen, np integer nvn ! number of vertical nodes from unit 11 file integer nvp ! number of horizontal nodes from unit 11 file INTEGER nhnn ! horizontal nodes counter INTEGER nvnn ! vertical nodes counter INTEGER sdu(nproc) ! subdomain unit numbers for unit 11 files INTEGER looper ! timesnap looper INTEGER nodepnw CHARACTER*120, ALLOCATABLE :: FD2D_MSG(:), FD_MSG(:,:) ! REAL(SZ), ALLOCATABLE :: fdData1(:,:) !(MNP,NFEN) full domain data ! REAL(SZ), ALLOCATABLE :: fdData2(:,:) !(MNP,NFEN) full domain data ! REAL(SZ), ALLOCATABLE :: sdData1(:,:) !(MNP,NFEN) subdomain data ! REAL(SZ), ALLOCATABLE :: sdData2(:,:) !(MNP,NFEN) subdomain data ! REAL(SZ), ALLOCATABLE :: fdData2D(:) !(MNP) 2D full domain data ! REAL(SZ), ALLOCATABLE :: sdData2D(:) !(MNP) 2D subdomain data ! REAL(SZ), ALLOCATABLE :: fdData2D2(:) !(MNP) 2D full domain data ! REAL(SZ), ALLOCATABLE :: sdData2D2(:) !(MNP) 2D subdomain data LOGICAL success ! .true. if all files opened successfully if (IDEN.lt.5) then CALL OpenPrepFiles(11, 'initial density forcing ', & 1, nproc, sdu, success) else WRITE(*,*) 'NOTE: Unit 11 file will be from netCDF.' RETURN ! note early return endif IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 11 files not preprocessed.' RETURN ! note early return ENDIF C C Read header information from full domain unit 11 file READ(11,80) header1 READ(11,80) header2 C C Transcribe header information. DO iproc = 1, nproc WRITE(sdu(iproc),80) header1 WRITE(sdu(iproc),80) header2 ENDDO C C Check node number data for consistency (paranoia). READ(11,80) nvn_nvp IF (C2DDI) THEN READ(nvn_nvp,*) nvp nvn = nfen ELSE READ(nvn_nvp,*) nvn, nvp ENDIF IF ( nvn .ne. nfen .or. nvp .ne. nnodg ) then WRITE(*,*) 'WARNING: NVN or NVP not consistent with input data' WRITE(*,*) 'NVN=',nvn,' although NFEN=',nfen WRITE(*,*) 'NVP=',nvp,' although NNODG=',nnodg ENDIF C C Decompose density forcing data; format based on value of IDEN. C jgf45.12 This is designed to work for baroclinic 3D runs only, not C 2D runs. C WJP 03.11.2018 made to work for 2D runs too IF (C2DDI) THEN ALLOCATE ( FD2D_MSG(MNP) ) nbytes = 120*mnp call memory_alloc(nbytes) FD2D_MSG = ''; ELSE ALLOCATE ( FD_MSG(MNP,NFEN) ) nbytes = 120*mnp*nfen call memory_alloc(nbytes) ENDIF DO looper = 1,100000 ! until end IF (C2DDI) THEN DO i=1, nvp READ(11,'(A120)',END=411) Dummy ! get a flo val for this f.d. flow node do k = 1,len_trim(Dummy) if (Dummy(k:k).eq.' '.or.Dummy(k:k).eq.',') exit enddo READ(Dummy(1:k-1),*) nhnn FD2D_MSG(nhnn) = Dummy(k+1:120) !write(6,*) nhnn, FD2D_MSG(nhnn) ENDDO ELSE DO i=1, nvp DO j=1, nfen READ(11,*,END=411) nhnn, nvnn, FD_MSG(nhnn,nvnn) ! get a flo val for this f.d. flow node READ(FD_MSG,*) nvn, nvp ENDDO ENDDO ENDIF IF (C2DDI) THEN DO iproc = 1, nproc IF (looper.eq.1) THEN nodepnw = 0 ! Find number of nodes with non-zero values for this processor DO i=1, nnodp(iproc) IF (len_trim(FD2D_MSG(IMAP_NOD_LG(i,iproc))).gt.0) THEN nodepnw = nodepnw + 1 ENDIF ENDDO WRITE(sdu(iproc),*) nodepnw ENDIF DO i=1, nnodp(iproc) IF (len_trim(FD2D_MSG(IMAP_NOD_LG(i,iproc))).gt.0) THEN WRITE(sdu(iproc),81) i, FD2D_MSG(IMAP_NOD_LG(i,iproc)) ENDIF ENDDO ENDDO ELSE DO iproc = 1, nproc IF (looper.eq.1) WRITE(sdu(iproc),*) nfen, nnodp(iproc) DO i=1, nnodp(iproc) DO j=1, nfen IF (FD_MSG(IMAP_NOD_LG(i,iproc),j)(1:1).ne.' ') THEN WRITE(sdu(iproc),82) i, j, FD_MSG(IMAP_NOD_LG(i,iproc),j) ENDIF ENDDO ENDDO ENDDO ENDIF END DO 411 CLOSE (11) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO ! SELECT CASE (ABS(IDEN)) c read in the full domain data ! IF (C2DDI) THEN ! ALLOCATE ( fdData2D(MNP) ) ! nbytes = 8*mnp ! call memory_alloc(nbytes) ! DO i=1, NNODG ! READ(11,*) nhnn, fdData2D(nhnn) ! ENDDO ! ELSE ! ALLOCATE ( fdData1(MNP,NFEN) ) ! nbytes = 8*mnp*nfen ! call memory_alloc(nbytes) ! DO i=1, NNODG ! DO j=1, nfen ! READ(11,*) nhnn, nvnn, fdData1(nhnn,nvnn) ! ENDDO ! ENDDO ! ENDIF c write out subdomain data ! IF (C2DDI) THEN ! ALLOCATE ( sdData2D(MNP) ) ! nbytes = 8*mnp ! call memory_alloc(nbytes) ! DO iproc = 1, nproc ! WRITE(sdu(iproc),*) nnodp(iproc) ! DO i=1, nnodp(iproc) ! sdData2D(i) = fdData2D(IMAP_NOD_LG(i,iproc)) ! WRITE(sdu(iproc),*) i, sdData2D(i) ! ENDDO ! ENDDO ! DEALLOCATE ( fdData2D, sdData2D ) ! nbytes = 16*mnp ! call memory_dealloc(nbytes) ! ELSE ! ALLOCATE ( sdData1(MNP,NFEN) ) ! nbytes = 8*mnp*nfen ! call memory_alloc(nbytes) ! DO iproc = 1, nproc ! WRITE(sdu(iproc),*) nfen, nnodp(iproc) ! DO i=1, nnodp(iproc) c DO j=1, nfen ! sdData1(i,j) = fdData1(IMAP_NOD_LG(i,iproc),j) ! WRITE(sdu(iproc),*) i, j, sdData1(i,j) ! ENDDO c ENDDO ! ENDDO ! DEALLOCATE ( fdData1, sdData1 ) ! nbytes = 16*mnp*nfen ! call memory_dealloc(nbytes) ! ENDIF ! ! ! CASE(4,5) ! !C start by allocating ! IF (C2DDI) THEN ! ALLOCATE ( fdData2D(MNP), fdData2D2(MNP) ) ! fdData2D = 0.0d0; fdData2D2 = 0.0d0 ! nbytes = 16*mnp ! call memory_alloc(nbytes) ! ALLOCATE ( sdData2D(MNP), sdData2D2(MNP) ) ! nbytes = 16*mnp ! call memory_alloc(nbytes) c ELSE ! ALLOCATE ( fdData1(MNP,NFEN) ) ! ALLOCATE ( fdData2(MNP,NFEN) ) ! nbytes = 16*mnp*nfen ! call memory_alloc(nbytes) ! ALLOCATE ( sdData1(MNP,NFEN) ) ! ALLOCATE ( sdData2(MNP,NFEN) ) ! nbytes = 16*mnp*nfen ! call memory_alloc(nbytes) ! ENDIF !C !C--While ( NOT EOF ) Read densities from Global File !C ! looper = 0 ! DO WHILE(.true.) ! ! looper = looper + 1 ! !c read in the full domain data ! IF (C2DDI) THEN ! DO i=1, nvp ! READ(11,*,iostat=eof) nhnn,fdData2D(nhnn),fdData2D2(nhnn) c IF (eof.ne.0) EXIT ! ENDDO ! ELSE ! DO i=1, nvp ! DO j=1, nfen ! READ(11,*,iostat=eof) nhnn, nvnn, ! & fdData1(nhnn,nvnn),fdData2(nhnn,nvnn) ! IF (eof.ne.0) EXIT ! ENDDO ! IF (eof.ne.0) EXIT ! ENDDO c ENDIF ! !C EOF reached, lets exit ! IF (eof < 0) EXIT c !c write out subdomain data ! IF (C2DDI) THEN ! DO iproc = 1, nproc ! IF (looper.eq.1) WRITE(sdu(iproc),*) nnodp(iproc) ! DO i=1, nnodp(iproc) ! sdData2D(i) = fdData2D(IMAP_NOD_LG(i,iproc)) ! sdData2D2(i) = fdData2D2(IMAP_NOD_LG(i,iproc)) ! WRITE(sdu(iproc),*) i, sdData2D(i), sdData2D2(i) ! ENDDO ! ENDDO ! ELSE ! DO iproc = 1, nproc ! IF (looper.eq.1) WRITE(sdu(iproc),*) nfen, nnodp(iproc) ! DO i=1, nnodp(iproc) ! DO j=1, nfen ! sdData1(i,j) = fdData1(IMAP_NOD_LG(i,iproc),j) ! sdData2(i,j) = fdData2(IMAP_NOD_LG(i,iproc),j) ! WRITE(sdu(iproc),*) i, j, sdData1(i,j), sdData2(i,j) c ENDDO ! ENDDO ! ENDDO ! ENDIF ! ! ENDDO ! !C deallocating ! IF (C2DDI) THEN ! DEALLOCATE ( fdData2D, sdData2D ) ! DEALLOCATE ( fdData2D2, sdData2D2 ) ! nbytes = 32*mnp ! call memory_dealloc(nbytes) ! ELSE ! DEALLOCATE ( fdData1, fdData2 ) ! DEALLOCATE ( sdData1, sdData2 ) ! nbytes = 32*mnp*nfen ! call memory_dealloc(nbytes) ! ENDIF ! ! END SELECT ! cC !C Close full domain file and all subdomain files ! CLOSE(11) ! DO iproc=1, nproc ! CLOSE(sdu(iproc)) ! ENDDO C 80 FORMAT(A80) 81 FORMAT(I10,1x,A120) 82 FORMAT(2(I10),1x,A120) 1100 FORMAT(I10,32000(2X,E16.8)) C call memory_status() RETURN C--------------------------------------------------------------------------- END SUBROUTINE PREP11 C--------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E R E L O C A L I Z E C--------------------------------------------------------------------------- C C This routine allows re-localizing selected files after a prepall C operation. vjp 10/2006 C tcm v50.21 20110610 -- changed I8 to I12 format specifications C C--------------------------------------------------------------------------- SUBROUTINE RELOCALIZE() C--------------------------------------------------------------------------- USE PRE_GLOBAL USE PREP_WEIR,ONLY:NWEIRBNDRY use memory_usage IMPLICIT NONE integer :: nbytes = 0 INTEGER I, J, K, IPROC, INDX, ITEMP, idumy CHARACTER(14) LOCFN CHARACTER(80) skipped INTEGER,ALLOCATABLE :: LUNP(:) LOGICAL,ALLOCATABLE :: ISWEIR(:) C print *, "entering relocalize" ! print *, "nproc = ", nproc allocate( lunp(nproc) ) ! logical unit number for each subdomain do iproc=1, nproc lunp(iproc) = 105 + (iproc-1) enddo if (.not.allocated(nnodp)) then ALLOCATE(NNODP(NPROC)) nbytes = 4*nproc call memory_alloc(nbytes) endif if (.not.allocated(nelp)) then ALLOCATE(NELP(NPROC)) nbytes = 4*nproc call memory_alloc(nbytes) endif if (.not.allocated(netap)) then ALLOCATE(NETAP(NPROC)) nbytes = 4*nproc call memory_alloc(nbytes) endif if (.not.allocated(nfluxfp)) then ALLOCATE(NFLUXFP(NPROC)) nbytes = 4*nproc call memory_alloc(nbytes) endif DO IPROC = 1,NPROC LOCFN(1:14) = 'PE0000/fort.18' CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN (LUNP(IPROC),FILE=LOCFN) ENDDO print *, "from relocalize: reading local-to-global element maps" DO IPROC = 1,NPROC READ(LUNP(IPROC),'(A)') skipped ! read past fileFmt header Casey 100208: Changed I8 to I12. READ(LUNP(IPROC),'(8X,3I12)') NELG, MNEP, NELP(IPROC) ENDDO ! print *, "nelg = ", nelg if (.not.allocated(imap_el_lg)) then ALLOCATE ( IMAP_EL_LG(MNEP, NPROC) ) nbytes = 4*nproc*mnep call memory_alloc(nbytes) endif DO IPROC = 1,NPROC DO I=1, NELP(IPROC) Casey 100208: Changed I8 to I12. READ(LUNP(IPROC),'(I12)') idumy IMAP_EL_LG(I,IPROC) = abs(idumy) ENDDO ENDDO print *, "from relocalize: reading local-to-global node maps" DO IPROC = 1,NPROC READ(LUNP(IPROC),'(8X,3I12)') NNODG, MNPP, NNODP(IPROC) !tcm v50.21 ENDDO ! print *, "nnodg = ", nnodg if (.not.allocated(imap_nod_lg)) then ALLOCATE ( IMAP_NOD_LG(MNPP, NPROC) ) nbytes = 4*nproc*mnpp call memory_alloc(nbytes) endif DO IPROC = 1,NPROC DO I=1, NNODP(IPROC) READ(LUNP(IPROC),'(I12)') idumy !tcm v50.21 IMAP_NOD_LG(I,IPROC) = abs(idumy) ENDDO ENDDO C This section for prep15 IF ((PREP_15.eqv..true.).or.(PREP_20.eqv..true.)) THEN print *, "from relocalize: reading nfluxf for each subdomain" DO IPROC = 1,NPROC READ(LUNP(IPROC),'(8X,I12)') NFLUXFP(IPROC) !tcm v50.21 ENDDO print *, "from relocalize: reading neta for each subdomain" DO IPROC = 1,NPROC READ(LUNP(IPROC),'(8X,3I12)') idumy, NETA_MAX, NETAP(IPROC) !tcm v50.21 ENDDO if (.not.allocated(obnode_lg)) then ALLOCATE ( OBNODE_LG(NETA_MAX, NPROC) ) nbytes = 4*nproc*neta_max call memory_alloc(nbytes) endif print *, "from relocalize: reading open boundary table" DO IPROC = 1,NPROC DO I=1, NETAP(IPROC) READ(LUNP(IPROC),'(I12)') OBNODE_LG(I,IPROC) !tcm v50.21 ENDDO ENDDO ENDIF ! Build Global-to-Local Node Map if (.not.allocated(itotproc)) then ALLOCATE ( ITOTPROC(NNODG) ) nbytes = 4*nnodg call memory_alloc(nbytes) endif DO I = 1,NNODG ITOTPROC(I) = 0 ENDDO DO IPROC = 1,NPROC DO I = 1,NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) ITOTPROC(INDX) = ITOTPROC(INDX) + 1 ENDDO ENDDO MNEI = 0 DO I = 1,NNODG IF (ITOTPROC(I) .gt. MNEI) MNEI = ITOTPROC(I) ENDDO print *, "MNEI = ", MNEI if (.not.allocated(imap_nod_gl2)) then ALLOCATE( IMAP_NOD_GL2( 2*MNEI, NNODG) ) nbytes = 8*mnei*nnodg call memory_alloc(nbytes) endif print *, "allocated imap_nod_GL2" DO I = 1,NNODG ITOTPROC(I) = 0 ENDDO DO IPROC = 1,NPROC DO J = 1,NNODP(IPROC) INDX = IMAP_NOD_LG(J,IPROC) ITOTPROC(INDX) = ITOTPROC(INDX) + 1 ITEMP = (ITOTPROC(INDX)-1)*2 + 1 IMAP_NOD_GL2(ITEMP,INDX) = IPROC IMAP_NOD_GL2(ITEMP+1,INDX) = J ENDDO ENDDO !jgf50.35: Need this for --prep13 option. if (.not.allocated(imap_nod_gl)) then ALLOCATE (IMAP_NOD_GL(2,NNODG)) nbytes = nbytes + 8*mnp call memory_alloc(nbytes) endif print *, "allocated imap_nod_GL" ! jgf50.35: Formulate the global-to-local ! mapping for resident nodes DO IPROC=1,NPROC DO J=1,NNODP(IPROC) INDX = IMAP_NOD_LG(J,IPROC) IF (ITOTPROC(INDX).eq.1) THEN IMAP_NOD_GL(1,INDX) = IPROC IMAP_NOD_GL(2,INDX) = J ENDIF ENDDO ENDDO !zc...If we're using time varying weirs, we need to ! find out which processors have weir (4,24) boundaries ! in the case that we're not passing through PREP14 IF(USE_TVW)THEN ALLOCATE(ISWEIR(1:NNODG)) ISWEIR(:) = .FALSE. DO K=1,NBOU SELECT CASE(IBTYPE(K)) CASE(4,24,5,25) DO J=1,NVELL(K) ISWEIR(NBVV(K,J))=.TRUE. ISWEIR(IBCONNR(K,J))=.TRUE. ENDDO CASE(3,13,23) DO J=1,NVELL(K) ISWEIR(NBVV(K,J))=.TRUE. ENDDO CASE DEFAULT I=I+NVELL(K) END SELECT ENDDO DO IPROC=1,NPROC DO J=1,NNODP(IPROC) INDX=IMAP_NOD_LG(J,IPROC) IF(ISWEIR(INDX))NWEIRBNDRY(IPROC)=1 ENDDO ENDDO ENDIF call memory_status() print *, "leaving relocalize" RETURN C--------------------------------------------------------------------------- END SUBROUTINE RELOCALIZE C--------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 1 3 C--------------------------------------------------------------------------- C C jgf46.00 This subroutine will break up the full domain nodal C attributes file into subdomains. C C jgf48.47 Rewritten to only open a smaller number of subdomains C at a time (256 by default) C C jgf48.50 Fixed bug (remove ALLOCATABLE from vars that don't need C it). Also adding following documentation: C C BY DEFAULT, ONLY 256 SUBDOMAINS WILL BE PREPPED AT A TIME TO AVOID C OPENING TOO MANY FILES ON CERTAIN PLATFORMS. THIS NUMBER CAN BE C CONTROLLED BY THE PARAMETER MAXOPENFILES. C C--------------------------------------------------------------------------- subroutine prep13() C--------------------------------------------------------------------------- use pre_global, only : useNodalAttrNames, nnodg, nnodp, nproc, & prep5354flag, prep2001flag use memory_usage use nodalattributes IMPLICIT NONE C integer :: nbytes = 0 INTEGER ll ! line loop counter INTEGER m ! attribute default value counter INTEGER :: k INTEGER iproc ! subdomain loop counter INTEGER sdu(nproc) ! subdomain unit number for unit 13 files INTEGER NumNotDefault ! number of nodes specified in the file CHARACTER(len=80) header ! header comments in unit 13 files CHARACTER(len=80),ALLOCATABLE :: AttrName(:) ! label for attribute!tgaf13mod CHARACTER(len=80) Units ! label for physical units CHARACTER(len=80) Skipped ! data we want to skip over REAL(SZ) DefaultVal(12) ! default value of attribute INTEGER, ALLOCATABLE :: NoOfVals(:) ! at each node for each attribute INTEGER Mode !=0 to count, =1 to write LOGICAL success ! .true. if all files opened successfully INTEGER, ALLOCATABLE :: SDNumND(:,:) ! subdomain # of nodes not default C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. INTEGER, PARAMETER :: maxOpenFiles = 256 INTEGER startProc INTEGER endProc INTEGER deltaProc C C Perform decomposition over range of subdomains. startProc = 1 DO WHILE ( startProc .le. nproc ) deltaProc = nproc - startProc IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc C C Open full domain and subdomain fort.13 files. CALL OpenPrepFiles(13, 'nodal attributes ', & startProc, endProc, sdu, success) C IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 13 files not preprocessed.' RETURN ! note early return ENDIF C C Read header information from full domain unit 13 file READ(13,'(A80)') header READ(13,*) NumOfNodes ! number of nodes according to unit 13 READ(13,*) NAttr ! number of attributes in the unit 13 file C C Check to make sure that the number of nodes in the nodal C attributes file is the same as in the grid file (unit 14). IF (NumOfNodes.NE.NNODG) THEN WRITE(6,9900) 9900 FORMAT(////,1X,'!!!!!!!!!! FATAL ERROR !!!!!!!!!', & //,1X,'The number of nodes in the grid file (unit 14) and' & /,1X,'the nodal attributes file (unit 13) must match.', & //,1X,'!!!!!! EXECUTION WILL NOW BE TERMINATED !!!!!!',//) CALL EXIT(1) ! We're toast. ENDIF C C Transcribe header information into subdomain unit 13 files DO iproc = startProc, endProc WRITE(sdu(iproc),'(A80)') header WRITE(sdu(iproc),*) NNODP(iproc) WRITE(sdu(iproc),*) NAttr ENDDO C C Transcribe attribute names from full domain file to subdomains. ALLOCATE(NoOfVals(NAttr)) ALLOCATE(AttrName(NAttr))!tgaf13mod DO k=1, NAttr READ(13,'(A80)') AttrName(k)!tgaf13mod READ(13,'(A80)') Units READ(13,*) NoOfVals(k) READ(13,*) (DefaultVal(m),m=1,NoOfVals(k)) DO iproc=startProc, endProc WRITE(sdu(IPROC),'(A80)') AttrName(k)!tgaf13mod WRITE(sdu(IPROC),'(A80)') Units WRITE(sdu(IPROC),*) NoOfVals(k) WRITE(sdu(IPROC),'(12(1x,e16.9))') & (DefaultVal(m),m=1,NoOfVals(k)) END DO END DO C C Allocate and initialize the matrix for the number of Non Default C nodes in each SubDomain for each nodal attribute ALLOCATE(SDNumND(nproc,NAttr)) nbytes = 8*nproc*nattr call memory_alloc(nbytes) DO iproc=startProc,endProc DO k=1, NAttr SDNumND(iproc,k)=0 END DO END DO C We need to figure out how many nodes go into each subdomain C for each attribute. CALL processNodalAttr(NAttr, NoOfVals, 0, sdu, SDNumND, & startProc, endProc, naType,AttrName)!tgaf13mod C C Now rewind and advance to the beginning of the data again REWIND(13) DO ll=1, 3 READ(13,*) skipped ! skip header, NumOfNodes, NAttr END DO DO k=1, NAttr DO ll=1, 4 READ(13,*) skipped ! skip AttrName,Units,NoOfVals,Default END DO END DO C C Now read each of the nodal attributes and transcribe them to the C appropriate subdomain. CALL processNodalAttr(NAttr, NoOfVals, 1, sdu, SDNumND, & startProc, endProc, naType,AttrName)!tgaf13mod DEALLOCATE(SDNumND,NoOfVals) DEALLOCATE(AttrName)!tgaf13mod nbytes = 8*nproc*nattr call memory_dealloc(nbytes) C C Close full domain and subdomain files CLOSE (13) DO iproc=startProc, endProc CLOSE(sdu(iproc)) ENDDO startProc = endProc + 1 END DO C DW IF ( .NOT. prep5354flag .and. .NOT. prep2001flag) THEN if (allocated(useNodalAttrNames)) then DEALLOCATE(useNodalAttrNames) nbytes = 4*nwp call memory_dealloc(nbytes) endif ENDIF C call memory_status() RETURN C--------------------------------------------------------------------------- END SUBROUTINE PREP13 C--------------------------------------------------------------------------- C ---------------------------------------------------------------- C S U B R O U T I N E P R O C E S S N O D A L A T T R C ---------------------------------------------------------------- C C jgf46.00 Subroutine to support PREP13. This subroutine is called C twice; once to determine the number of nodes with non-default C values going into each subdomain, then a second time to actually C place the data in the subdomain files. C C This is necessary because the attributes in the subdomain files C must each have the number of non-default values at the top, and C this information cannot be known until we have processed the C entire fulldomain file. C C ---------------------------------------------------------------- subroutine processNodalAttr(NAttr, NumCol, mode, sdu, SDNumND, & startProc, endProc, naType,AttrName)!tgaf13mod use pre_global use sizes, only : ASCII, XDMF use nodalattributes, only : na implicit none C INTEGER,intent(in) :: NAttr ! number of attributes in the file INTEGER,intent(in),dimension(NAttr) :: NumCol !NumCol for attribute INTEGER,intent(in) :: Mode !=0 to count and return, =1 to write INTEGER,intent(in),dimension(nproc) :: sdu !i/o unit number array INTEGER,intent(inout),dimension(nproc,NAttr) :: SDNumND INTEGER,intent(in) :: startProc INTEGER,intent(in) :: endProc INTEGER,intent(in) :: naType ! ascii and xdmf are supported CHARACTER(len=80),intent(in),dimension(NAttr) :: AttrName ! label for attribute!tgaf13mod INTEGER NumNotDefault ! number of nodes specified in the file INTEGER NodeNum ! full domain node number INTEGER SDNode ! subdomain node number INTEGER i ! node loop counter INTEGER j ! column loop counter INTEGER k ! attribute loop counter INTEGER m ! mapping loop counter INTEGER iproc ! subdomain loop counter INTEGER iproc2 ! mapped subdomain CHARACTER(len=80) curAttrName ! label for current attribute!tgaf13mod REAL(SZ), ALLOCATABLE :: AttrData(:) ! attribute data INTEGER :: curAttrInd ! index corresponding to currently named attribute CHARACTER(len=80) Skipped ! data we want to skip over C DO k=1, NAttr select case(naType) case(ASCII) read(13,*) curAttrName!tgaf13mod case(XDMF) curattrName = trim(adjustl(na(k)%attrName))!tgaf13mod case default write(6,'(a,i0,a)') 'ERROR: Nodal attribute file format ',naType, & ' is not supported by adcprep.' CALL EXIT(1) end select IF (Mode.eq.1) THEN DO iproc=startProc,endProc WRITE(sdu(iproc),'(A80)') curAttrName!tgaf13mod END DO ENDIF CTGA 20180524: Adjusted code to better handle out-of-order attributes in the body curAttrInd=-1 DO i=1,NAttr IF (TRIM(ADJUSTL(curAttrName)).eq.TRIM(ADJUSTL(AttrName(i)))) THEN curAttrInd=i EXIT ENDIF ENDDO !If a matching attribute wasn't found, write error and stop IF (curAttrInd.EQ.-1) THEN WRITE(6,'(A)')'ERROR: Nodal attribute in body could not be ' & //'found in header: '//curAttrName CALL EXIT(1) ENDIF ALLOCATE(attrData(numCol(curAttrInd)))!tgaf13mod select case(naType) case(ASCII) read(13,*) numNotDefault case(XDMF) numNotDefault = na(k) % numNodesNotDefault case default write(6,'(a,i0,a)') 'ERROR: Nodal attribute file format ',naType, & ' is not supported by adcprep.' CALL EXIT(1) end select IF (Mode.eq.1) THEN DO iproc=startProc,endProc WRITE(sdu(iproc),*) SDNumND(iproc,k) END DO ENDIF DO i=1, NumNotDefault select case(naType) case(ASCII) READ(13,*) nodeNum, (AttrData(j),j=1,NumCol(curAttrInd))!tgaf13mod IF (curAttrName.eq."sponge_generator_layer") THEN IF (AttrData(NumCol(curAttrInd)) > 0) THEN prep5354flag = .true. ENDIF IF (AttrData(NumCol(curAttrInd)).eq.-1.or. & AttrData(NumCol(curAttrInd)).eq.2) THEN prep2001flag = .true. IF (.not.allocated(nodeNumSP)) THEN allocate(nodeNumSP(NumNotDefault)); nodeNumSP=0 ENDIF nodeNumSP(i) = nodeNum ENDIF ENDIF case(XDMF) nodeNum = na(k) % nonDefaultNodes(i) attrData(:) = na(k) % nonDefaultVals(:,nodeNum) case default write(6,'(a,i0,a)') 'ERROR: Nodal attribute file format ',naType, & ' is not supported by adcprep.' CALL EXIT(1) end select IF (ITOTPROC(NodeNum).eq.1) THEN iproc = IMAP_NOD_GL(1,NodeNum) IF ( (iproc.lt.startProc) .or. (iproc.gt.endProc) ) THEN CYCLE ! skip it if it does not map to our range of procs ENDIF IF (Mode.eq.0) SDNumND(iproc,k) = SDNumND(iproc,k)+1 IF (Mode.eq.1) THEN SDNode = IMAP_NOD_GL(2,NodeNum) WRITE(sdu(iproc),1100) NodeNum,(AttrData(j),j=1,NumCol(curAttrInd))!tgaf13mod ENDIF ELSE DO m=1, ITOTPROC(NodeNum) iproc2 = IMAP_NOD_GL2(2*(m-1)+1,NodeNum) DO iproc=startProc, endProc IF (iproc.EQ.iproc2) THEN !f.d. node maps to this s.d. IF (Mode.eq.0) THEN SDNumND(iproc,k)=SDNumND(iproc,k)+1 ENDIF IF (Mode.eq.1) THEN SDNode = IMAP_NOD_GL2(2*(m-1)+2,NodeNum) WRITE(sdu(iproc),1100) NodeNum, & (AttrData(j),j=1,NumCol(curAttrInd))!tgaf13mod ENDIF ENDIF END DO END DO END IF END DO DEALLOCATE(AttrData) IF (Mode.eq.1) THEN WRITE(6,'(A25,A80)') ' Finished processing ', curAttrName!tgaf13mod WRITE(6,*) 'for processor range ',startProc,' to ',endProc ENDIF END DO C C 1001 FORMAT('ERROR: The Nodal Attributes File (unit 13)') 1021 FORMAT('contains invalid name: ',A80) 1031 FORMAT('WARNING: Processed only one column of unrecognized ',A80) 1100 FORMAT(I10,32000(2X,E16.8)) C RETURN C ---------------------------------------------------------------- END SUBROUTINE ProcessNodalAttr C ---------------------------------------------------------------- C--------------------------------------------------------------------------- subroutine prep13XDMF() C--------------------------------------------------------------------------- use pre_global, only : useNodalAttrNames, nnodg, nnodp, nproc use memory_usage use nodalattributes use sizes, only : naFileName implicit none integer :: nbytes = 0 integer :: iproc ! subdomain loop counter integer :: sdu(nproc) ! subdomain unit number for unit 13 files integer :: Mode !=0 to count, =1 to write logical :: success ! .true. if all files opened successfully character(len=15) sdFileName ! subdomain file name !increased from 14 to 15 tcm v50.66.03 integer, allocatable :: SDNumND(:,:) ! subdomain # of nodes not default C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. integer, parameter :: maxOpenFiles = 256 integer :: startProc integer :: endProc integer :: deltaProc integer :: errorIO real(sz), allocatable :: diff(:) ! difference between nodal value and default value logical, allocatable :: areDefaultValues(:) integer :: nonDefaultCount integer :: i,j,k C call readNodalAttrXDMF() ! ! we need to compute the number of nondefault values and ! create a list of nodes with nondefault values do i=1,nAttr if (na(i)%numVals.eq.1) then ! machine precision prevents us from simply checking whether the ! value .ne. the default value diff = abs(na(i)%xdmfArray - na(i)%defaultVals(1)) na(i)%numNodesNotDefault = count(diff.gt.1.e-6) ! now allocate space for the non default values and populate them allocate(na(i)%nonDefaultVals(1,na(i)%numNodesNotDefault)) allocate(na(i)%nonDefaultNodes(na(i)%numNodesNotDefault)) ! now record the node number and value where the values are not ! the default nonDefaultCount = 1 do j=1,nnodg if (diff(j).gt.1.e-6) then na(i)%nonDefaultNodes(nonDefaultCount) = j na(i)%nonDefaultVals(1,nonDefaultCount) = na(i)%xdmfArray(j) nonDefaultCount = nonDefaultCount + 1 endif end do else ! determine the number of nondefault values areDefaultValues = .true. do j=1,nnodg do k=1,na(i)%numVals if (abs(na(i)%xdmfMatrix(k,j)-na(i)%defaultVals(k)).gt.1.e-6) then areDefaultValues(j) = .false. endif enddo enddo ! now allocate space for the non default values and populate them na(i)%numNodesNotDefault = count(areDefaultValues.eqv..false.) allocate(na(i)%nonDefaultVals(na(i)%numVals,na(i)%numNodesNotDefault)) allocate(na(i)%nonDefaultNodes(na(i)%numNodesNotDefault)) nonDefaultCount = 1 do j=1,nnodg if (areDefaultValues(j).eqv..false.) then na(i)%nonDefaultNodes(nonDefaultCount) = j do k=1,na(i)%numVals na(i)%nonDefaultVals(k,nonDefaultCount) = & na(i)%xdmfMatrix(k,j) end do nonDefaultCount = nonDefaultCount + 1 endif end do endif end do C C Perform decomposition over range of subdomains. startProc = 1 do while ( startProc .lt. nproc ) deltaProc = nproc - startProc if ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc ! Open each of the subdomain files do iproc = startProc, endProc sdu(iproc) = 105 + (iproc-1) sdFileName = 'PE0000/fort.13' call iwrite(sdFileName, 3, 6, iproc-1) open(unit=sdu(iproc), file=sdFileName, iostat=ErrorIO) Success = .true. IF ( ErrorIO .GT. 0 ) THEN write(6,'(a,a,a)') "ERROR: Subdomain file " & // trim(sdFileName) // " cannot be opened." Success = .false. CALL EXIT(1) endif enddo C C Transcribe header information into subdomain unit 13 files do iproc = startProc, endProc write(sdu(iproc),'(a)') trim(adjustl(nodalAttributesComment)) write(sdu(iproc),*) NNODP(iproc) write(sdu(iproc),*) NAttr do i=1,nAttr write(sdu(iproc),'(a)') trim(adjustl(na(i)%attrName)) write(sdu(iproc),'(a)') trim(adjustl(na(i)%units)) write(sdu(iproc),'(99(i0))') na(i)%numVals write(sdu(iproc),'(99(F15.7))') (na(i)%defaultVals(j), j=1,na(i)%numVals) end do end do C C Allocate and initialize the matrix for the number of Non Default C nodes in each SubDomain for each nodal attribute ALLOCATE(SDNumND(nproc,nAttr)) nbytes = 8*nproc*nattr call memory_alloc(nbytes) SDNumND(:,:)=0 C We need to figure out how many nodes go into each subdomain C for each attribute. CALL processNodalAttr(NAttr, na%numVals, 0, sdu, SDNumND, & startProc, endProc, naType,na%attrName)!tgaf13mod C C Now read each of the nodal attributes and transcribe them to the C appropriate subdomain. CALL processNodalAttr(NAttr, na%numVals, 1, sdu, SDNumND, & startProc, endProc, naType,na%attrName)!tgaf13mod DEALLOCATE(SDNumND) nbytes = 8*nproc*nattr call memory_dealloc(nbytes) C C Close subdomain files DO iproc=startProc, endProc CLOSE(sdu(iproc)) ENDDO startProc = endProc + 1 END DO C if (allocated(useNodalAttrNames)) then DEALLOCATE(useNodalAttrNames) nbytes = 4*nwp call memory_dealloc(nbytes) endif C call memory_status() C--------------------------------------------------------------------------- end subroutine prep13XDMF C--------------------------------------------------------------------------- SUBROUTINE PREP14() USE PRE_GLOBAL USE PREP_WEIR,ONLY:NWEIRBNDRY C C---------------------------------------------------------------------------C C ( Serial Version 2/28/98 ) C C This routine writes a Local Grid file "fort.14" file for each subdomain C C using the domain decomposition of the ADCIRC grid created by the routine C C DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 34.03 C C C C---------------------------------------------------------------------------C C IMPLICIT NONE INTEGER I,I1,J,K,M,ETYPE,ITEMP,ITEMP2,ILNODE,ILNODE2,ILNODE3 INTEGER JD,JG,JP,IPROC,IPROC2,IPROC3,DISC,BBN,IBP,IBPPipe INTEGER INDX,INDEX2,ITOT,ITYPE,NUMS(10) CHARACTER LOCFN*14,PE*6 CHARACTER*80 OUTMSG C..... DW INTEGER:: IPER, II C..... DW ! ! NVELLP(K,PE) Number of Land Boundary Nodes of Segment K on PE ! IMAP_NOD_GL2(2(PE-1)+1,I) = PE assigned to Global Node I ! IMAP_NOD_GL2(2(PE-1)+2,I) = Local Node Number of Global Node I on PE ! vjp modified array to drop last dimension to save memory space ! LBINDEX_LG(K,I,PE) = Global Index of I-th Node on Land Boundary Segment K on PE C ETYPE = 3 ! The only Element-Type supported by ADCIRC is 3. C C-------------------------------------------------------------------------- C--MAIN LOOP: Write a Local Grid File ( fort.14 ) for each PE C-------------------------------------------------------------------------- C NETA_MAX = 0 ! max number of open boundary nodes on any subdomain C DO IPROC = 1,NPROC C LOCFN(1:14) = 'PE0000/fort.14' CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN (14,FILE=LOCFN) C C-------------------------------------------------------------------------- C--OPEN BOUNDARY NODES PROCESSING BEGINS HERE C-------------------------------------------------------------------------- C C--Partition the open boundary nodes between various processors C NETAP(IPROC) = 0 DO K=1, NOPE NVDLLP(K) = 0 DO J=1, NETA OBNODE_LG(J,IPROC) = 0 NBDVP(K,J) = 0 ENDDO ENDDO C ITOT = 0 DO K = 1,NOPE DO I = 1,NVDLL(K) ITOT = ITOT + 1 INDX = NBDV(K,I) DO J = 1,ITOTPROC(INDX) ITEMP = (J-1)*2+1 IPROC2 = IMAP_NOD_GL2(ITEMP,INDX) ILNODE = IMAP_NOD_GL2(ITEMP+1,INDX) IF (IPROC.EQ.IPROC2) THEN NETAP(IPROC) = NETAP(IPROC)+1 NVDLLP(K) = NVDLLP(K) + 1 NBDVP(K,NVDLLP(K)) = ILNODE OBNODE_LG(NETAP(IPROC),IPROC)=ITOT ENDIF ENDDO ENDDO ENDDO IF (NETAP(IPROC) > NETA_MAX) NETA_MAX = NETAP(IPROC) C NOPEP(IPROC) = 0 DO K = 1,NOPE IF (NVDLLP(K).NE.0) THEN NOPEP(IPROC) = NOPEP(IPROC) + 1 ENDIF ENDDO C C C-------------------------------------------------------------------------- C--LAND BOUNDARY NODES PROCESSING BEGINS HERE C-------------------------------------------------------------------------- C C--Partition Land Boundary Segments between PEs C NVELP(IPROC) = 0 DO K = 1,NBOU NVELLP(K) = 0 IBTYPEP(K,IPROC) = IBTYPE(K) ENDDO C DO K = 1,NBOU C C--Weir Land Boundary Node-Pair Case Cmod vjp 3/8/99 C mod to allow that each of Weir-node pair might be ghosts nodes C select case(IBTYPE(K)) ! ! weir boundaries case(4,24,5,25) DO I = 1,NVELL(K) INDX = NBVV(K,I) INDEX2 = IBCONNR(K,I) DO J = 1,ITOTPROC(INDX) ITEMP = (J-1)*2 + 1 IPROC2 = IMAP_NOD_GL2(ITEMP,INDX) ILNODE2 = IMAP_NOD_GL2(ITEMP+1,INDX) IF (IPROC.EQ.IPROC2) THEN DO JD = 1, ITOTPROC(INDEX2) ITEMP2 = (JD-1)*2 + 1 IPROC3 = IMAP_NOD_GL2(ITEMP2,INDEX2) ILNODE3 = IMAP_NOD_GL2(ITEMP2+1,INDEX2) IF (IPROC.EQ.IPROC3) THEN NVELP(IPROC) = NVELP(IPROC) + 1 NVELLP(K) = NVELLP(K) + 1 LBINDEX_LG(K,NVELLP(K)) = I NBVVP(K,NVELLP(K)) = ILNODE2 IBCONNRP(K,NVELLP(K)) = ILNODE3 ENDIF ENDDO ENDIF ENDDO ENDDO case(94) C.... BEG DW, periodic boundary condition C.... 2018: use similar trick used in weir-node pair II = 0 ; DO I = IPERPTR(K), IPERPTR(K+1) - 1 INDX = IPERCONN(I,1) ; ! global index: primary node INDEX2 = IPERCONN(I,2) ; ! global idnex: its slave node II = II + 1 ; DO J = 1, ITOTPROC(INDX) ITEMP = (J-1)*2 + 1 ; IPROC2 = IMAP_NOD_GL2(ITEMP,INDX) ; ! processor (may not be resident) ILNODE2 = IMAP_NOD_GL2(ITEMP+1,INDX) ; ! local index ! IF ( IPROC .EQ. IPROC2 ) THEN DO JD = 1, ITOTPROC(INDEX2) ITEMP2 = (JD - 1)*2 + 1 ; IPROC3 = IMAP_NOD_GL2(ITEMP2,INDEX2) ; ILNODE3 = IMAP_NOD_GL2(ITEMP2+1,INDEX2) ; IF ( IPROC .EQ. IPROC3 ) THEN NVELP(IPROC) = NVELP(IPROC) + 1 ; NVELLP(K) = NVELLP(K) + 1 ; LBINDEX_LG(K,NVELLP(K)) = II ; NBVVP(K,NVELLP(K)) = ILNODE2 ; C.... For now, use an exisitng interal boundary array C to hold the index of the slave node. In the future, C if need be, change to a CRS format to save memory. IBCONNRP(K,NVELLP(K)) = ILNODE3 ; END IF END DO END IF ! END DO END DO C.......... END DW, periodic bcs C C--All Other Land Boundary Node types C case default C ! for each node in this non-weir flux boundary DO I = 1,NVELL(K) ! find full domain node number INDX = NBVV(K,I) ! iterate over the subdomains where this boundary ! node is found DO J = 1,ITOTPROC(INDX) ITEMP = (J-1)*2 + 1 ! look up subdomain number IPROC2 = IMAP_NOD_GL2(ITEMP,INDX) ! look up node number in this subdomain ILNODE = IMAP_NOD_GL2(ITEMP+1,INDX) ! if the current subdomain matches this one IF (IPROC.EQ.IPROC2) THEN ! increment the total number of flux boundary nodes ! on this subdomain NVELP(IPROC) = NVELP(IPROC) + 1 ! increment number of nodes from this boundary ! that occur in this subdomain NVELLP(K) = NVELLP(K) + 1 ! add fulldomain node number for this boundary ! and subdomain node array position on this boundary ! to mapping LBINDEX_LG(K,NVELLP(K)) = I ! record subdomain node number for this boundary ! and subdomain boundary position NBVVP(K,NVELLP(K)) = ILNODE ENDIF ENDDO ENDDO ! ! @jasonfleming: it is possible for a single node of an ! island boundary to appear as a ghost node in a nearby ! subdomain, and if this single node is the first node ! on the fulldomain island boundary, it will also be the ! last node on the fulldomain boundary (because adcirc ! requires island boundaries to be closed). As a result, ! it can be erroneously translated as a two node subdomain ! boundary with the same node number listed twice. if ( nvellp(k).eq.2 ) then if ( nbvvp(k,1).eq.nbvvp(k,2) ) then write(*,'(a)') & 'ERROR: Two node boundary with identical node numbers.' if (strictBoundaries.eqv..false.) then NVELLP(K) = 0 write(*,'(a)') & 'INFO: Eliminating hanging boundary' & //' node from this subdomain.' endif endif endif C end select C ENDDO ! end loop over flux specified boundaries C Cmod 05/18/2004 rl -- I don't think this next part is the correct c way to handle islands. Rather, if an island is split by a domain, it c should remain an island. This will ensure that the boundary is c closed. The only error would occur in ghost node space, which is c not a problem since the answers are not used there anyway. Cmod 12/18/98 vjp --this section re-written C--If a PE has only part of a closed internal land boundary C modify its local IBTYPE to be an external land boundary segment C of the same type by decrementing its IBTYPE. C and remove a closing loop node if present C c DO K=1, NBOU c IF (NVELLP(K).LT.NVELL(K)) THEN c IF ( (IBTYPEP(K,IPROC).EQ.1) c & .OR.(IBTYPEP(K,IPROC).EQ.11) c & .OR.(IBTYPEP(K,IPROC).EQ.21)) THEN c decrement ibtype c IBTYPEP(K,IPROC) = IBTYPEP(K,IPROC)-1 C remove loop closing node c IF (NVELLP(K).GT.1.AND. c & NBVVP(K,NVELLP(K)).EQ.NBVVP(K,1)) THEN c NVELLP(K) = NVELLP(K)-1 c ENDIF c ENDIF c ENDIF c ENDDO C If a segment contains only one node, remove the segment from the list C (NOTE: rl 5/18/04 I don't see how this could possibly happen, including C ghost nodes) ! ! @jasonfleming: it is possible for a single node of a ! land boundary to appear as a ghost node in a nearby ! subdomain. DO K=1, NBOU IF (NVELLP(K).EQ.1) THEN write(*,'(a,i0,a,i0,a)') & 'ERROR: The land boundary number ',k, & ' is only one node long in subdomain ',iproc,'.' if ( strictBoundaries.eqv..false. ) then NVELLP(K) = 0 write(*,'(a)') 'INFO: Eliminating hanging boundary' & //' node from this subdomain.' endif ENDIF ENDDO C C--Count the number of land boundary segments on PE IPROC. C NBOUP(IPROC) = 0 DO K = 1,NBOU IF (NVELLP(K).NE.0) THEN NBOUP(IPROC) = NBOUP(IPROC) + 1 ENDIF ENDDO C C--Count to check correctness of NVELP C DISC=0 ! LB Nodes with non-zero normal discharge (river) BBN=0 ! Mainland Barrier Boundary Nodes (external overflow) IBP=0 ! Internal Barrier Boundary Pairs (levee) IBPPipe=0 ! internal barrier boundary pairs (levee with cross barrier pipes) ITEMP = 0 ! mainland and island IPER = 0 C C jgf46.21 Added support for IBTYPE=52. DO K=1,NBOU IF (NVELLP(K).EQ.0) THEN cycle ENDIF ITYPE = IBTYPEP(K,IPROC) ! kmd - added for rivers in baroclinic simulation IF (ABS(ITYPE/100).EQ.1) THEN ITYPE = (ABS(ITYPE)-100)*(ITYPE/ABS(ITYPE)) END IF ! jgf50.21: Added support for IBTYPE=32 and replaced ! if/then statements with a select statement. select case(ITYPE) case(2,12,22,32,52) DISC = DISC + NVELLP(K) case(3,13,23) BBN = BBN + NVELLP(K) case(4,24) IBP = IBP + NVELLP(K) case(5,25) IBPPipe = IBPPipe + NVELLP(K) case(94) ! DW/WP periodic boundary IPER = IPER + NVELLP(K) case default ITEMP = ITEMP + NVELLP(K) end select I1 = 0 ! loop over all boundary nodes on this subdomain DO I=1,NVELLP(K) ! if the boundary is an island boundary IF ((ITYPE.EQ.1).OR.(ITYPE.EQ.11).OR.(ITYPE.EQ.21)) THEN ! if this is the last boundary node on this subdomain ! and ! if the subdomain node number is not equal to ! the first subdomain node number IF ((I.EQ.NVELLP(K)).AND.(NBVVP(K,I).NE.I1)) THEN ITEMP = ITEMP + 1 ! increment the number of nodes associated with this boundary on this subdomain ENDIF ENDIF ! set i1 equal to the subdomain node number for the first ! node on this boundary IF (I.EQ.1) THEN I1 = NBVVP(K,I) ENDIF ENDDO END DO C c print *, IPROC-1,ITEMP,DISC,BBN,2*IBP ITEMP = ITEMP + DISC + BBN + 2*IBP + 2*IBPPipe + IPER; IF (ITEMP.NE.NVELP(IPROC)) THEN c print *, "changed value from ",NVELP(IPROC)," to ",ITEMP NVELP(IPROC) = ITEMP ENDIF IF (NVELP(IPROC)+1.GT.MNVEL) THEN print *, "NVEL exceeds parameter value MNVEL on PE",IPROC print *, "local NVEL value = ",ITEMP CALL EXIT(1) ENDIF C C--Construct a LBCODE for each Land Boundary Node of this PE C JP=0 DO K = 1,NBOU DO I=1, NVELLP(K) JP = JP+1 LBCODEP(JP,IPROC) = IBTYPEP(K,IPROC) ENDDO ENDDO C C--Determine whether there are any normal flow boundaries local to PE C ! kmd - changed for rivers in baroclinic simulations NFLUXFP(IPROC) = 0 DO K=1, NBOU IF (NVELLP(K).GT.0) THEN ITYPE=IBTYPE(K) IF (ABS(ITYPE/100).EQ.1) THEN ITYPE = (ABS(ITYPE)-100)*(ITYPE/ABS(ITYPE)) END IF IF ((ITYPE.EQ.2).OR.(ITYPE.EQ.12) & .OR.(ITYPE.EQ.32) & .OR.(ITYPE.EQ.22).OR.(ITYPE.EQ.52)) THEN NFLUXFP(IPROC) = 1 ENDIF ENDIF ENDDO C C-------------------------------------------------------------------------- C--BEGIN WRITING LOCAL GRID ( fort.14 ) FILE HERE C-------------------------------------------------------------------------- C C--Write Mesh Data C WRITE(14,80) AGRID C NUMS(1) = NELP(IPROC) NUMS(2) = NNODP(IPROC) c cjgf45.06 CALL INSERT(SIZEMSG,OUTMSG,NUMS,2) cjgf45.06 WRITE(14,80) OUTMSG WRITE(14,43) NELP(IPROC),NNODP(IPROC) !jgf45.06 C DO J = 1,NNODP(IPROC) INDX = IMAP_NOD_LG(J,IPROC) WRITE(14,44) LABELS(INDX),X(INDX),Y(INDX),DP(INDX) ENDDO c DO J = 1,NELP(IPROC) ! WRITE(14,45) J,ETYPE,NNEP(1,J,IPROC),NNEP(2,J,IPROC), ! & NNEP(3,J,IPROC) WRITE(14,45) J,ETYPE,LABELS(IMAP_NOD_LG(NNEP(1,J,IPROC),IPROC)), & LABELS(IMAP_NOD_LG(NNEP(2,J,IPROC),IPROC)), & LABELS(IMAP_NOD_LG(NNEP(3,J,IPROC),IPROC)) ENDDO 43 FORMAT(2I8) 44 FORMAT(I8,3(E20.12)) 45 FORMAT(I8,I2,3(I9)) C C--Write Open Boundary Data C CALL NEWINDEX(NOPEMSG,OUTMSG,NOPEP(IPROC)) WRITE(14,80) OUTMSG C CALL NEWINDEX(NETAMSG,OUTMSG,NETAP(IPROC)) WRITE(14,80) OUTMSG C ITOT = 0 DO K = 1,NOPE IF (NVDLLP(K).GT.0)THEN ITOT = ITOT + 1 Casey 090304: Added the following section. If we are coupling to SWAN, C then we also want to give the global number of each C boundary segment. #ifndef ADCSWAN CALL NEWINDEX(NVDLLMSG(K),OUTMSG,NVDLLP(K)) #else NUMS(1) = NVDLLP(K) NUMS(2) = K CALL INSERT(NVDLLMSG(K),OUTMSG,NUMS,2) #endif WRITE(14,80) OUTMSG DO I = 1,NVDLLP(K) WRITE(14,*) LABELS(IMAP_NOD_LG(NBDVP(K,I),IPROC)) ENDDO ENDIF ENDDO C C--Write Land Boundary Data C CALL NEWINDEX(NBOUMSG,OUTMSG,NBOUP(IPROC)) WRITE(14,80) OUTMSG C CALL NEWINDEX(NVELMSG,OUTMSG,NVELP(IPROC)) WRITE(14,80) OUTMSG C DO K = 1,NBOU IF(NVELLP(K).GT.0)THEN ITYPE = IBTYPEP(K,IPROC) NUMS(1) = NVELLP(K) NUMS(2) = ITYPE Casey 090304: Added the following section. If we are coupling to SWAN, C then we also want to give the global number of each C boundary segment. #ifndef ADCSWAN CALL INSERT(NVELLMSG(K),OUTMSG,NUMS,2) #else NUMS(3) = NOPE + K CALL INSERT(NVELLMSG(K),OUTMSG,NUMS,3) #endif WRITE(14,80) OUTMSG C select case(itype) case default DO I = 1,NVELLP(K) WRITE(14,'(I8)') LABELS(IMAP_NOD_LG(NBVVP(K,I),IPROC)) ENDDO case(3,13,23) IF(USE_TVW)NWEIRBNDRY(IPROC) = 1 DO I = 1,NVELLP(K) INDX = LBINDEX_LG(K,I) WRITE(14,81) LABELS(IMAP_NOD_LG(NBVVP(K,I),IPROC)), & BAR1(K,INDX),BAR2(K,INDX) ENDDO case(4,24) IF(USE_TVW)NWEIRBNDRY(IPROC) = 1 DO I = 1,NVELLP(K) INDX = LBINDEX_LG(K,I) WRITE(14,82) LABELS(IMAP_NOD_LG(NBVVP(K,I),IPROC)), & LABELS(IMAP_NOD_LG(IBCONNRP(K,I),IPROC)), & BAR1(K,INDX),BAR2(K,INDX),BAR3(K,INDX) ENDDO case(5,25) DO I = 1,NVELLP(K) INDX = LBINDEX_LG(K,I) WRITE(14,83) LABELS(IMAP_NOD_LG(NBVVP(K,I),IPROC)), & LABELS(IMAP_NOD_LG(IBCONNRP(K,I),IPROC)), & BAR1(K,INDX),BAR2(K,INDX),BAR3(K,INDX), & BAR4(K,INDX),BAR5(K,INDX),BAR6(K,INDX) ENDDO case(94) C..... DW add support for ITYPE = 94 DO I = 1,NVELLP(K) INDX = LBINDEX_LG(K,I) WRITE(14,84) LABELS(IMAP_NOD_LG(NBVVP(K,I),IPROC)), & LABELS(IMAP_NOD_LG(IBCONNRP(K,I),IPROC)) ENDDO end select ENDIF ENDDO C CLOSE(14) C END DO ! end loop over subdomains C C--Print Summary of Boundary Node Decomposition C print *, " " print *, "Boundary Node Decomposition Data" print *, "DOMAIN NOPE NETA NBOU NVEL NWEIR" WRITE(*,90) "GLOBAL",NOPE, NETA, NBOU, NVEL, NWEIR DO IPROC=1, NPROC PE(1:6) = 'PE0000' CALL IWRITE(PE,3,6,IPROC-1) WRITE(*,90) PE,NOPEP(IPROC),NETAP(IPROC), & NBOUP(IPROC),NVELP(IPROC),NWEIRP(IPROC) ENDDO C 80 FORMAT(A80) 81 FORMAT(I8,2X,E13.6,2X,E13.6) 82 FORMAT(I8,2X,I8,2X,E13.6,2X,E13.6,2X,E13.6) 83 FORMAT(I8,2X,I8,6(2X,E13.6)) 84 FORMAT(I8,2X,I8) 90 FORMAT(1X,A6,5I8) C RETURN END SUBROUTINE PREP14 C---------------------------------------------------------------------------C C ( Serial Version 2/28/98 ) C C This routine writes a Local Input file "fort.15" file for each subdomain C C using the domain decomposition of the ADCIRC grid created by the routine C C DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 34.03 C C C C Modifications by RL on 10/9/01 to accomodate NWS = -2 C C---------------------------------------------------------------------------C SUBROUTINE PREP15() USE PRE_GLOBAL use memory_usage USE PREP_WEIR USE HARM, ONLY : NAMEFR use subprep, only : subdomainOn, found_sm_nml ! NCSU Subdomain Modeling use nodalattributes, only : outputTau0 IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,K,M,JG,JP,KK, ios_stations INTEGER INDX,ITOT,ILNODE,IPROC,IPROC2,ITYPE,NUMS(10) CHARACTER LOCFN*80,PE*6,LOCSTATFN*20 INTEGER,ALLOCATABLE :: NTIMEVARYINGWEIRP(:) CHARACTER*80 OUTMSG C C--Write a Local Input file ( fort.15 ) for each PE C ! max number of stations in any subdomain NSTAE_MAX = 0; NSTAV_MAX = 0; NSTAM_MAX = 0; NSTAC_MAX = 0 C ALLOCATE(NTIMEVARYINGWEIRP(NPROC)) NTIMEVARYINGWEIRP(:)=0 DO 1000 IPROC = 1,NPROC C LOCFN = 'PE0000/fort.15' CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN (15,FILE=TRIM(LOCFN)) C WRITE(15,80) RUNDES WRITE(15,80) RUNID WRITE(15,80) OVERMSG WRITE(15,80) ABOUTMSG WRITE(15,80) SCREENMSG WRITE(15,80) HOTMSG WRITE(15,80) ICSMSG WRITE(15,80) IMMSG Casey 140701: Debug. C IF (CBaroclinic) THEN !jgf46.28 IF (CBaroclinic.AND.IM.GE.10) THEN !jgf46.28 WRITE(15,80) IDENMSG ENDIF WRITE(15,80) IBFMSG WRITE(15,80) IFAMSG WRITE(15,80) ICAMSG WRITE(15,80) ICATMSG WRITE(15,80) NWPMSG IF (NWP.gt.0) THEN !jgf46.00 write nodal attributes DO I=1, NWP WRITE(15,80) useNodalAttrNames(I) ENDDO ENDIF WRITE(15,80) NCORMSG WRITE(15,80) NTIPMSG C jgfdebug46.02 Added check for NWS=45 to write NWS=5 IF (NWS.EQ.45) THEN WRITE(15,'(A1)') "5" ELSE WRITE(15,80) NWSMSG ENDIF WRITE(15,80) RAMPMSG WRITE(15,80) GMSG WRITE(15,80) TAU0MSG C jgf47.11 Added writing of limits for time varying tau0 IF ( (TAU0.le.-5.d0).AND.(TAU0.gt.-6.d0) ) THEN WRITE(15,80) TAU0LIMMSG ENDIF WRITE(15,80) DTMSG WRITE(15,80) STATMSG WRITE(15,80) REFTMSG ! tcm v49.64.01 No changes needed here for the use of ICE IF((NWS.EQ.0).AND.(NRS.GE.1)) WRITE(15,80) RSTIMMSG ! sb46.28sb03 IF((NWS.EQ.1).AND.(NRS.GE.1)) WRITE(15,80) RSTIMMSG ! sb46.28sb03 C jgfdebug46.02 Added check for NWS=45. C jgf46.02 Added NWS=8. C jgf46.16 Merged: C rjw added NWS=19: asymmetric hurricane wind model v2.0 C jie added NWS=20: generalized asymmetric vortex model C sb46.28sb01 added NWS=12: OWI format C jgf50.38.05: added NWS=15: HWind format C tcm v51.06.02 added NWS=16: GFDL Met Data C xyc v52.30 added NWS=7 to be consistent with NWS=6 C arc added nws13 190110 C jgf: Added NWS=30 (GAHM+OWI) IF ((ABS(NWS).EQ.2).OR.(ABS(NWS).EQ.4).OR.(ABS(NWS).EQ.45).OR. & (ABS(NWS).EQ.5).OR.(ABS(NWS).EQ.6).OR.(ABS(NWS).EQ.7) & .OR.(ABS(NWS).EQ.8).OR.(ABS(NWS).EQ.10).OR.(ABS(NWS).EQ.12) & .OR.(ABS(NWS).EQ.15).OR.(ABS(NWS).EQ.14) & .OR.(ABS(NWS).EQ.16).OR.(ABS(NWS).EQ.30) & .OR.(ABS(NWS).EQ.19).OR.(ABS(NWS).EQ.29) & .OR.(ABS(NWS).EQ.20).OR.(ABS(NWS).EQ.13) & .OR.(ABS(NWS).EQ.17)) THEN ! for NUOPC: added by PV, SM WRITE(15,80) WSMSG1 ENDIF IF (NWS.EQ.3) THEN WRITE(15,80) WSMSG1 WRITE(15,80) WSMSG2 ENDIF WRITE(15,80) RNDAYMSG WRITE(15,80) DRAMPMSG WRITE(15,80) COEFMSG WRITE(15,80) H0MSG WRITE(15,80) SLMSG WRITE(15,80) TAUMSG WRITE(15,80) ESLMSG WRITE(15,80) CORIMSG WRITE(15,80) NTIFMSG DO I=1,NTIF WRITE(15,80) TIPOTAG(I) WRITE(15,80) TPKMSG(I) ENDDO WRITE(15,80) NBFRMSG DO I=1,NBFR WRITE(15,80) BOUNTAG(I) WRITE(15,80) AMIGMSG(I) ENDDO DO I=1,NBFR WRITE(15,80) ALPHA1(I) DO J=1,NETAP(IPROC) WRITE(15,80) EMOMSG(I,OBNODE_LG(J,IPROC)) ENDDO ENDDO WRITE(15,80) ANGMSG C C--If there were any normal flow boundaries local to PE, process them C C PRINT *, NFFRMSG C PRINT *, "NFLUXFP(",IPROC,") = ", NFLUXFP(IPROC) IF (NFLUXFP(IPROC).EQ.1) THEN C NFLBNP = 0 DO I=1, NFLBN INDX = FLBN(I) DO J=1, ITOTPROC(INDX) IPROC2 = IMAP_NOD_GL2(2*(J-1)+1,INDX) IF (IPROC.EQ.IPROC2) THEN NFLBNP = NFLBNP + 1 FLBNXP(NFLBNP) = FLBNX(I) ENDIF ENDDO ENDDO C WRITE(15,80) NFFRMSG IF ((NFFR.NE.0).AND.(NFFR.NE.-1)) THEN DO I=1,NFFR WRITE(15,80) FBOUNTAG(I) WRITE(15,80) FREQMSG(I) ENDDO DO I=1,NFFR WRITE(15,80) ALPHA2(I) DO J=1,NFLBNP WRITE(15,80) QNMSG(I,FLBNXP(J)) cdebug print *, "PE=",IPROC," FLUXNODE=",FLBNXP(J) ENDDO ENDDO ENDIF C ENDIF Cobell C--IF THERE ARE INTERNAL/EXTERNAL TIME VARYING FLUX BOUNDARIES, PARSE TO PEs C IF(USE_TVW)THEN IF(ALLOCATED(NWEIRBNDRY).AND.NTIMEVARYINGWEIR.GT.0)THEN IF(NWEIRBNDRY(IPROC).EQ.1)THEN !...If this processor has Time varying weirs, count them NTIMEVARYINGWEIRP(IPROC) = 0 DO I=1,NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) DO J = 1,NTIMEVARYINGWEIR IF(INDX.EQ.NODES_TVW(J))THEN NTIMEVARYINGWEIRP(IPROC) = & NTIMEVARYINGWEIRP(IPROC) + 1 ENDIF ENDDO ENDDO ENDIF !...Open the local PE fort.tvw LOCFN = 'PE0000/'//TRIM(tvw_file) CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN(FILE=TRIM(LOCFN),UNIT=98,ACTION="WRITE") IF(NTIMEVARYINGWEIRP(IPROC).GT.0)THEN !...Write fort.tvw namelist file for the ! local PE WRITE(98,*) NTIMEVARYINGWEIRP(IPROC) DO I=1,NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) DO J = 1,NTIMEVARYINGWEIR IF(INDX.EQ.NODES_TVW(J))THEN WRITE(98,'(A)') & TRIM(ADJUSTL(TIMEVARYINGWEIRMSSG(J))) ENDIF ENDDO ENDDO ELSE !...Write an empty fort.tvw to avoid old files from ! previous decompositions WRITE(98,*) 0 ENDIF CLOSE(98) ENDIF ENDIF C C--Write Local Elevation Station Info: C--Create Local-to-Global element "ownership" of an elevation station C C WRITE(15,80) STAEMSG !jgf45.07 we may have changed NOUTE in adcprep WRITE(15,*) NOUTE,TOUTSE,TOUTFE,NSPOOLE C NSTAEP(IPROC) = 0 DO K = 1,abs(NSTAE) !tcm -- added the comments below DO J=1,NELP(IPROC) !nelp(iproc) lists the number of elements from processor iproc INDX = abs(IMAP_EL_LG(J,IPROC)) ! global element number IF (INDX.EQ.NNSEG(K)) THEN !nnseg(k) contains the element number station k resides in NSTAEP(IPROC) = NSTAEP(IPROC) + 1 KK = K if (STAE_SHARE(K) > -1) KK = -K IMAP_STAE_LG(NSTAEP(IPROC),IPROC) = KK STAE_SHARE(K) = IPROC ! tcm v51.20.03 once found exit the element loop exit ENDIF ENDDO ENDDO NSTAE_MAX = MAX(NSTAEP(IPROC),NSTAE_MAX) C C... update the number of stations for this proc's domain if (use_elev_stat_file ) then !tcm v51.20.03 CALL INSERT(NSTAEMSG,OUTMSG,(/-NSTAEP(IPROC)/),1) !keep the negative sign for fort.15 write(15,80) OUTMSG CALL INSERT(NSTAEMSG,OUTMSG,NSTAEP(IPROC),1) LOCSTATFN(1:20) = 'PE0000/elev_stat.151' CALL IWRITE(LOCstatFN,3,6,IPROC-1) ios_stations = 0 open(unit=151,file=locstatfn, & status='unknown',iostat=ios_stations) write(151,80) OUTMSG else CALL INSERT(NSTAEMSG,OUTMSG,NSTAEP(IPROC),1) write(15,80) OUTMSG endif C C... write the stations located in this proc's domain DO K=1,NSTAEP(IPROC) INDX = abs(IMAP_STAE_LG(K,IPROC)) if (use_elev_stat_file) then write(151,80) STAELOC(INDX) else WRITE(15,80) STAELOC(INDX) endif ENDDO if (use_elev_stat_file ) close(151) C C--Write Local Velocity Station Info: C--Create Local-to-Global element "ownership" of an velocity station C WRITE(15,*) NOUTV,TOUTSV,TOUTFV,NSPOOLV C NSTAVP(IPROC) = 0 DO K = 1,abs(NSTAV) DO J=1,NELP(IPROC) INDX = abs(IMAP_EL_LG(J,IPROC)) IF (INDX.EQ.NNSVG(K)) THEN NSTAVP(IPROC) = NSTAVP(IPROC) + 1 KK = K if (STAV_SHARE(K) > -1) KK = -K IMAP_STAV_LG(NSTAVP(IPROC),IPROC) = KK STAV_SHARE(K) = IPROC ! tcm v51.20.03 once found exit the element loop exit ENDIF ENDDO ENDDO NSTAV_MAX = MAX(NSTAVP(IPROC),NSTAV_MAX) C if (use_vel_stat_file ) then !tcm v51.20.03 CALL INSERT(NSTAVMSG,OUTMSG,(/-NSTAVP(IPROC)/),1) !keep the negative sign for fort.15 write(15,80) OUTMSG CALL INSERT(NSTAVMSG,OUTMSG,NSTAVP(IPROC),1) LOCSTATFN(1:19) = 'PE0000/vel_stat.151' CALL IWRITE(LOCstatFN,3,6,IPROC-1) ios_stations = 0 open(unit=151,file=locstatfn(1:19), & status='unknown',iostat=ios_stations) write(151,80) OUTMSG else CALL INSERT(NSTAVMSG,OUTMSG,NSTAVP(IPROC),1) write(15,80) OUTMSG endif C DO K=1,NSTAVP(IPROC) INDX = abs(IMAP_STAV_LG(K,IPROC)) if (use_vel_stat_file ) then WRITE(151,80) STAVLOC(INDX) else WRITE(15,80) STAVLOC(INDX) endif ENDDO if (use_vel_stat_file ) close(151) C C--If IM=10 Write Concentration Station Info: C--Create Local-to-Global element "ownership" of an concentration station C NSTACP(IPROC) = 0 IF (C2D_PTrans.or.C3D_PTrans) THEN !jgf46.28 C C WRITE(15,80) STACMSG !jgf45.07 we may have changed NOUTC in adcprep WRITE(15,*) NOUTC,TOUTSC,TOUTFC,NSPOOLC C DO K = 1,abs(NSTAC) DO J=1,NELP(IPROC) INDX = abs(IMAP_EL_LG(J,IPROC)) IF (INDX.EQ.NNSCG(K)) THEN NSTACP(IPROC) = NSTACP(IPROC) + 1 KK = K if (STAC_SHARE(K) > -1) KK = -K IMAP_STAC_LG(NSTACP(IPROC),IPROC) = KK STAC_SHARE(K) = IPROC ! tcm v51.20.03 once found exit the element loop exit ENDIF ENDDO ENDDO NSTAC_MAX = MAX(NSTACP(IPROC),NSTAC_MAX) C C... update the number of stations for this proc's domain if (use_conc_stat_file ) then !tcm v51.20.03 CALL INSERT(NSTACMSG,OUTMSG,(/-NSTACP(IPROC)/),1) !keep the negative sign for fort.15 write(15,80) OUTMSG CALL INSERT(NSTACMSG,OUTMSG,NSTACP(IPROC),1) LOCSTATFN(1:20) = 'PE0000/conc_stat.151' CALL IWRITE(LOCstatFN,3,6,IPROC-1) ios_stations = 0 open(unit=151,file=locstatfn, & status='unknown',iostat=ios_stations) write(151,80) OUTMSG else CALL INSERT(NSTACMSG,OUTMSG,NSTACP(IPROC),1) write(15,80) OUTMSG endif C ... write the stations located in this proc's domain DO K=1,NSTACP(IPROC) INDX = abs(IMAP_STAC_LG(K,IPROC)) IF (use_conc_stat_file) then write(151,80) STACLOC(INDX) ELSE WRITE(15,80) STACLOC(INDX) ENDIF ENDDO IF (use_conc_stat_file) close(151) C ENDIF C C--Write Local Meterological Station Info: C--Create Local-to-Global element "ownership" of an elevation station C NSTAMP(IPROC) = 0 IF (NWS.NE.0) THEN WRITE(15,*) NOUTM,TOUTSM,TOUTFM,NSPOOLM DO K = 1,abs(NSTAM) DO J=1,NELP(IPROC) INDX = abs(IMAP_EL_LG(J,IPROC)) IF (INDX.EQ.NNSMG(K)) THEN NSTAMP(IPROC) = NSTAMP(IPROC) + 1 KK = K if (STAM_SHARE(K) > -1) KK = -K IMAP_STAM_LG(NSTAMP(IPROC),IPROC) = KK STAM_SHARE(K) = IPROC ! tcm v51.20.03 once found exit the element loop exit ENDIF ENDDO ENDDO NSTAM_MAX = MAX(NSTAMP(IPROC),NSTAM_MAX) C C... update the number of stations for this proc's domain if (use_met_stat_file ) then !tcm v51.20.03 CALL INSERT(NSTAMMSG,OUTMSG,(/-NSTAMP(IPROC)/),1) !keep the negative sign for fort.15 write(15,80) OUTMSG CALL INSERT(NSTAMMSG,OUTMSG,NSTAMP(IPROC),1) LOCSTATFN(1:19) = 'PE0000/met_stat.151' CALL IWRITE(LOCstatFN,3,6,IPROC-1) ios_stations = 0 open(unit=151,file=locstatfn(1:19), & status='unknown',iostat=ios_stations) write(151,80) OUTMSG else CALL INSERT(NSTAMMSG,OUTMSG,NSTAMP(IPROC),1) write(15,80) OUTMSG endif C C... write the stations located in this proc's domain DO K=1,NSTAMP(IPROC) INDX = abs(IMAP_STAM_LG(K,IPROC)) IF (use_met_stat_file) then WRITE(151,80) STAMLOC(INDX) ELSE WRITE(15,80) STAMLOC(INDX) ENDIF ENDDO IF (use_met_stat_file) CLOSE(151) ENDIF C C--Write Local Elevation Data Output Info C C WRITE(15,80) OUTGEMSG !jgf45.07 we may have changed NOUTGE in adcprep WRITE(15,*) NOUTGE,TOUTSGE,TOUTFGE,NSPOOLGE C C--Write Local Velocity Data Output Info C C WRITE(15,80) OUTGVMSG !jgf45.07 we may have changed NOUTGV in adcprep WRITE(15,*) NOUTGV,TOUTSGV,TOUTFGV,NSPOOLGV C C jgf45.07 write subdomain concentration data output info if necessary C IF (IM.EQ.10) WRITE(15,*) NOUTGC,TOUTSGC,TOUTFGC,NSPOOLGC C C--Write Local Wind Velocity Data Output Info ( added 4/16/98 vjp ) C C jgf45.07 we may have changed NOUTGW in adcprep C IF (NWS.NE.0) WRITE(15,80) OUTGWMSG IF (NWS.NE.0) WRITE(15,*) NOUTGW,TOUTSGW,TOUTFGW,NSPOOLGW C C--Write Harmonic Analysis Data C WRITE(15,80) HARFRMSG DO I=1,NHARFR WRITE(15,'(A10)') NAMEFR(I) WRITE(15,80) HAFREMSG(I) c WRITE(15,*) HAFREQ(I),HAFF(I),HAFACE(I) ENDDO C WRITE(15,80) HARPARMSG WRITE(15,80) OUTHARMSG C C--Write Hot Start Info C WRITE(15,80) HSTARMSG C C--Write Solver Info C WRITE(15,80) SOLVMSG C C--Write 3DVS Info C IF(C3DVS) THEN CALL PREP15_3DVS(IPROC) c ELSEIF(C3DDSS) THEN c CALL PREP15_3DDSS(IPROC) ENDIF C C jgf48.03 Write netCDF metadata, if necessary IF (useNetCDF.eqv..true.) THEN WRITE(15,*) trim(adjustl(title)) WRITE(15,*) trim(adjustl(institution)) WRITE(15,*) trim(adjustl(source)) WRITE(15,*) trim(adjustl(history)) WRITE(15,*) trim(adjustl(references)) WRITE(15,*) trim(adjustl(comments)) WRITE(15,*) trim(adjustl(host)) WRITE(15,*) trim(adjustl(convention)) WRITE(15,*) trim(adjustl(contact)) WRITE(15,*) trim(adjustl(base_date)) ENDIF c... tcm v50.66.02 additions for time varying bathymetry IF (FOUND_TBC_NML) then !If there was a namelist in the original fort.15 put it in the decomp 15's ! IF (NDDT.NE.0) THEN write(15,*) '! -- Begin Time Varying Bathymetry Inputs --' write(15,TimeBathyControl) write(15,*) '! -- End Time Varying Bathymetry Inputs --' ENDIF C #if defined CSWAN || defined ADCSWAN write(15,*) '! -- Begin SWAN Output Control Namelist --' write(15,SWANOutputControl) write(15,*) '! -- End SWAN Output Control Namelist --' #endif ! tcm v50.79 Changed so that metControl namelist is only written if it was found in the ! original fort.15 file. Also changed the single line write, which is missing some commas ! to a multiple line write. The single line write was causing problems on ! some compilers because the character DragLawString could end up being written ! on multiple lines and this caused issues. This section ! should only be written if there was a namelist in the original fort.15. ! if (found_metCon_nml) then !metControl namelist was found so write it in the parsed files write(15,*) '! -- Begin Met Control Namelist --' ! write(15,*) "&metControl WindDragLimit=",WindDragLimit, ! & " DragLawString='",DragLawString,"' rhoAir=",rhoAir," /" write(15,*) "&metControl " write(15,*) " WindDragLimit=",Winddraglimit,"," write(15,*) " DragLawString='",trim(Draglawstring),"'," write(15,*) " outputWindDrag=",outputWindDrag,"," write(15,*) " rhoAir=",rhoAir,"," write(15,*) " invertedBarometerOnElevationBoundary=", & invertedBarometerOnElevationBoundary,"," write(15,*) " nPowellSearchDomains=",nPowellSearchDomains write(15,*) "/" write(15,*) '! -- End Met Control Namelist --' endif if (found_tvw_nml) then write(15,*) '! -- Begin TVW Control Namelist --' write(15,*) "&TVWControl " write(15,*) " USE_TVW=",USE_TVW,"," write(15,*) " TVW_FILE='",TRIM(ADJUSTL(TVW_FILE)),"'," write(15,*) " NOUT_TVW=",NOUT_TVW,"," write(15,*) " TOUTS_TVW=",TOUTS_TVW,"," write(15,*) " TOUTF_TVW=",TOUTF_TVW,"," write(15,*) " NSPOOL_TVW=",NSPOOL_TVW write(15,*) "/" write(15,*) '! -- End TVW Control Namelist --' endif Casey 121019: Added multiplication factor to be used before sending winds to coupled wave models. IF(FOUND_WC_NML)THEN WRITE(15,*) '! -- Begin Wave Coupling Namelist --' WRITE(15,waveCoupling) WRITE(15,*) '! -- End Wave Coupling Namelist --' ENDIF #ifdef ADCNETCDF Casey 180318: Added NWS=13 if(FOUND_OWINC_NML)then write(15,'(a,a,a,a,a,a,a)') & "&owiWindNetcdf NWS13File='",TRIM(ADJUSTL(NWS13File)), & "' NWS13ColdStartString='", & TRIM(ADJUSTL(NWS13ColdStartString)), & "' NWS13WindMultiplier='", & TRIM(ADJUSTL(NWS13WindMultiplier)), & "' NWS13GroupForPowell='", & TRIM(ADJUSTL(NWS13GroupForPowell)),"' /" endif #endif ! NCSU Subdomain Modeling if (FOUND_SM_NML) then WRITE(15,*) "&subdomainModeling subdomainOn=",subdomainOn," /" endif ! wet dry control if (foundWetDryControlNameList) then WRITE(15,'(a,l,a,l,a,l,a,l,a,i1,a)') & "&wetDryControl outputNodeCode=",outputNodeCode, & " outputNOFF=",outputNOFF," noffActive=",noffActive, & " StatPartWetFix=",StatPartWetFix, & " How2FixStatPartWet=",How2FixStatPartWet, " /" endif ! jgf52.08.02: inundation output control if (foundInundationOutputControlNamelist) then write(15,'(a,l,a,f15.8,a)') & '&inundationOutputControl inundationOutput=', & inundationOutput,' inunThresh=',inunThresh," /" endif c... tcm v52.30.01 additions for Smag_Control Namelist IF (FOUND_SMAG_NML) then !If there was a namelist in the original fort.15 put it in the decomp 15's write(15,*) '! -- Begin Smagorinski Inputs --' write(15,Smag_Control) write(15,*) '! -- End Smagorinski Inputs --' ENDIF ! jgf: dynamicWaterlevel control namelist if (foundCorrectionControlNamelist) then write(15,'(a,a, a,i0, a,f15.8, a,a, a,f20.8, a,f20.8, a)') & '&dynamicWaterLevelCorrectionControl dynamicWaterLevelCorrectionFileName="', & trim(adjustl(dynamicWaterLevelCorrectionFileName)), & '", dynamicWaterLevelCorrectionSkipSnaps=',dynamicWaterLevelCorrectionSkipSnaps, & ', dynamicWaterlevelCorrectionMultiplier=',dynamicWaterLevelCorrectionMultiplier, & ', dynamicWaterLevelCorrectionRampReferenceTime="', & trim(dynamicWaterLevelCorrectionRampReferenceTime), & '", dynamicWaterLevelCorrectionRampStart=',dynamicWaterLevelCorrectionRampStart, & ', dynamicWaterLevelCorrectionRampEnd=',dynamicWaterLevelCorrectionRampEnd,' /' endif C... wjp additions for WarnElev Namelist IF (FOUND_WARNELEV_NML) then !If there was a namelist in the original fort.15 put it in the decomp 15's write(15,*) '! -- Begin WarnElev Control NameList --' write(15,WarnElevControl) write(15,*) '! -- End WarnElev Control NameList --' ENDIF c... wjp additions for Ali Dispersion Control Namelist IF (FOUND_ALIDISP_NML) then !If there was a namelist in the original fort.15 put it in the decomp 15's write(15,*) '! -- Begin AliDispersion Control NameList --' write(15,AliDispersionControl) write(15,*) '! -- End AliDispersion Control NameList --' ENDIF c... wjp additions for density Control Namelist IF (FOUND_DENSITY_NML) then !If there was a namelist in the original fort.15 put it in the decomp 15's write(15,*) '! -- Begin density Control NameList --' write(15,'(3A)') '&densityControl densityRunType="', & TRIM(densityRunType),'",' write(15,'(3A)') ' densityFilename="',TRIM(densityFilename),'"' write(15,'(A,I0,A)') ' densityTimeIterator=',densityTimeIterator,"," write(15,'(3A)') ' densityForcingType="',TRIM(densityForcingType),'" /' write(15,*) '! -- End density Control NameList --' ENDIF CLOSE(15) C 1000 CONTINUE IF(C3DVS.and.(IEVC.EQ.0)) THEN DEALLOCATE ( EVTot ) nbytes = 8*nfen call memory_dealloc(nbytes) ENDIF C C--Print Summary of Stations C print *, " " print *, "Station Data" print *, "DOMAIN NSTAE NSTAV NSTAC NSTAM" WRITE(*,92) "GLOBAL",abs(NSTAE),abs(NSTAV), & abs(NSTAC),abs(NSTAM) DO IPROC=1, NPROC PE(1:6) = 'PE0000' CALL IWRITE(PE,3,6,IPROC-1) WRITE(*,92) PE,NSTAEP(IPROC),NSTAVP(IPROC), . NSTACP(IPROC),NSTAMP(IPROC) ENDDO C RETURN 80 FORMAT(A80) 92 FORMAT(1X,A6,4I8) END SUBROUTINE PREP15 C C---------------------------------------------------------------------------C C ( Serial Version 6/24/02 ) C C This routine writes the 3DVS info in the Local Input file "fort.15" file C C for each subdomain using the domain decomposition of the ADCIRC grid C C created by the routine DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 41.11a C C C jgf45.11 Updated to handle new format of 3D input files with stations C defined by coordinates rather than node numbers. C---------------------------------------------------------------------------C SUBROUTINE PREP15_3DVS(IPROC) USE PRE_GLOBAL USE GLOBAL_3DVS, ONLY : SIGMA IMPLICIT NONE INTEGER N ! vertical grid layer counter INTEGER IPROC ! subdomain counter INTEGER SDStation ! subdomain station INTEGER FDStation ! full domain station INTEGER SDEle ! subdomain station element INTEGER FDEle ! full domain element c jgf45.10 removed IDIAG WRITE(15,80) IDENMSG WRITE(15,80) SLIPMSG WRITE(15,80) Z0MSG WRITE(15,80) ALPMSG WRITE(15,80) FEMSG C jgf45.12 Added code to record thicknesses of vertical grid layers, C if necessary. IF(IGC.EQ.0) THEN DO N=1,NFEN WRITE(15,*) Sigma(N) ENDDO ENDIF WRITE(15,80) EVCMSG C jgf45.12 Add code to record vertical eddy viscosity profile. IF(IEVC.EQ.0) THEN DO N=1,NFEN WRITE(15,*) EVTot(N) ENDDO ENDIF IF((IEVC.EQ.50).OR.(IEVC.EQ.51)) WRITE(15,80) THETAMSG C ------------------------------------------------------------- C jgf45.11 Create mapping from full domain 3D density station C elements to corresponding elements in subdomains. Write out C subdomain station locations to fort.15 file. C ------------------------------------------------------------- WRITE(15,*) I3DSD,TO3DSDS,TO3DSDF,NSPO3DSD C kmd48.33bc changed IF(NSTA3DD.NE.0) THEN NNSTA3DDP(IPROC) = 0 DO FDStation = 1, NSTA3DD DO SDEle = 1, NELP(IPROC) FDEle = abs(IMAP_EL_LG(SDEle,IPROC)) IF ( FDEle .eq. NNS3DDG(FDStation) ) THEN NNSTA3DDP(IPROC) = NNSTA3DDP(IPROC) + 1 IMAP_STA3DD_LG(NNSTA3DDP(IPROC),IPROC) = FDStation ENDIF END DO END DO WRITE(15,*) NNSTA3DDP(IPROC) DO SDStation = 1, NNSTA3DDP(IPROC) FDStation = IMAP_STA3DD_LG(SDStation,IPROC) WRITE(15,80) STA3DDLOC(FDStation) ENDDO ELSE WRITE(15,80) NSTA3DDMSG ENDIF C ------------------------------------------------------------- C jgf45.11 Create mapping from full domain 3D velocity station C elements to corresponding elements in subdomains. Write out C velocity subdomain station locations to fort.15 file. C ------------------------------------------------------------- WRITE(15,*) I3DSV,TO3DSVS,TO3DSVF,NSPO3DSV C kmd48.33bc changed IF(NSTA3DV.NE.0) THEN NNSTA3DVP(IPROC) = 0 DO FDStation = 1, NSTA3DV DO SDEle = 1, NELP(IPROC) FDEle = abs(IMAP_EL_LG(SDEle,IPROC)) IF ( FDEle .eq. NNS3DVG(FDStation) ) THEN NNSTA3DVP(IPROC) = NNSTA3DVP(IPROC) + 1 IMAP_STA3DV_LG(NNSTA3DVP(IPROC),IPROC) = FDStation ENDIF END DO END DO WRITE(15,*) NNSTA3DVP(IPROC) DO SDStation = 1, NNSTA3DVP(IPROC) FDStation = IMAP_STA3DV_LG(SDStation,IPROC) WRITE(15,80) STA3DVLOC(FDStation) ENDDO ELSE WRITE(15,80) NSTA3DVMSG ENDIF C ------------------------------------------------------------- C jgf45.11 Create mapping from full domain 3D turbulence station C elements to corresponding elements in subdomains. Write out C turbulence subdomain station locations to fort.15 file. C ------------------------------------------------------------- WRITE(15,*) I3DST,TO3DSTS,TO3DSTF,NSPO3DST C kmd48.33bc changed IF(NSTA3DT.NE.0) THEN NNSTA3DTP(IPROC) = 0 DO FDStation = 1, NSTA3DT DO SDEle = 1, NELP(IPROC) FDEle = abs(IMAP_EL_LG(SDEle,IPROC)) IF ( FDEle .eq. NNS3DTG(FDStation) ) THEN NNSTA3DTP(IPROC) = NNSTA3DTP(IPROC) + 1 IMAP_STA3DT_LG(NNSTA3DTP(IPROC),IPROC) = FDStation ENDIF END DO END DO WRITE(15,*) NNSTA3DTP(IPROC) DO SDStation = 1, NNSTA3DTP(IPROC) FDStation = IMAP_STA3DT_LG(SDStation,IPROC) WRITE(15,80) STA3DTLOC(FDStation) ENDDO ELSE WRITE(15,80) NSTA3DTMSG ENDIF WRITE(15,80) DGDMSG WRITE(15,80) DGVMSG WRITE(15,80) DGTMSG C kmd48.33bc add 3D boundary condition information IF (CBAROCLINIC) THEN WRITE(15,80) RESBCFLAGMSG IF (RES_BC_FLAG.NE.0) THEN IF (NOPEP(IPROC).GT.0) THEN WRITE(15,80) BCTIMEMSG WRITE(15,80) BCSTATMSG END IF IF (BCFLAG_TEMP.NE.0) THEN WRITE(15,80) TBCTIMEMSG END IF END IF END IF IF (CBAROCLINIC) THEN WRITE(15,80) SPONGEDISTMSG WRITE(15,80) EqnstateMSG END IF C C jgf45.12: Write out the parameters for the transport equation, if C necessary. IF (C3D_BTrans) THEN C Lateral and vertical diffusion coefficients. WRITE(15,*) NLSD, NVSD WRITE(15,*) NLTD, NVTD C Time stepping coefficient for the transport equation terms. WRITE(15,*) ALP4 C kmd48.33 took out as it is no longer needed with new heat flux boundary conditions C Temperature boundary condition file type, if necessary ! IF ( IDEN .eq. 3 .or. IDEN .eq. 4 ) THEN ! WRITE(15,*) NTF ! ENDIF ENDIF RETURN 80 FORMAT(A80) 81 FORMAT(I8,2E15.8,2I8,A32) 82 FORMAT(500I8) END C----------------------------------------------------------------------- C End of subroutine PREP15_3DVS C----------------------------------------------------------------------- SUBROUTINE PREP18() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C ( Serial Version 6/10/2011 ) C C This Routine writes a message-passing file "fort.18" for each subdomain C C of the domain decomposition created by DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 50.21 C C C C tcm V50.21 -- Changed all I8 formats to I12 C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 INTEGER N1, N2, N3, KMIN INTEGER I,J,K,M,ITEMP,IPR,IPR1 INTEGER INDX,ITOT,IEL,IELG,ILNODE,IPROC,ITYPE INTEGER,ALLOCATABLE :: RES_NODE(:) CHARACTER LOCFN*14,PE*6 C C Allocate local arrays C ALLOCATE ( RES_NODE(MNPP) ) nbytes = 4*mnpp call memory_alloc(nbytes) C C--Write Message-Passing File for each PE C DO 1000 I = 1,NPROC C LOCFN(1:14) = 'PE0000/fort.18' CALL IWRITE(LOCFN,3,6,I-1) OPEN (18,FILE=LOCFN) write(18,3050) FileFmtVersion, 0, 0 !vjp 9/17/06 C--Write the Global indexes of all local elements in local element order Casey 100209: Changed I8 to I12. WRITE(18,3000) NELG, MNEP, NELP(I) ! number of Global elements DO J = 1,NELP(I) INDX = IMAP_EL_LG(J,I) WRITE(18,'(I12)') INDX ! Global index of local element ENDDO C--Write the Global indexes of all local nodes in local node order C write global index as positive if a resident node and negative C if a ghost node WRITE(18,3001) NNODG, MNPP, NNODP(I) ! number of Global nodes ITOT = 0 DO J = 1,NNODP(I) INDX = IMAP_NOD_LG(J,I) IPR = IMAP_NOD_GL(1,INDX) IF (IPR.EQ.I)THEN ITOT = ITOT + 1 RES_NODE(ITOT) = J WRITE(18,'(I12)') INDX ! Global index of resident node ELSE WRITE(18,'(I12)') -1*INDX ! Global index of ghost node ENDIF ENDDO IF (ITOT.NE.NOD_RES_TOT(I)) STOP 'ERROR IN # OF RES. NODES' C--Write local normal flow boundary flag C--vjp This info is used only for relocalizing fort.15 WRITE(18,3002) NFLUXFP(I) ! normal flow b.c. flag for subdomain C--Write global and local total number of elevation boundary nodes C--vjp This info is used only for relocalizing fort.15 WRITE(18,3003) NETA, NETA_MAX, NETAP(I) ! number of global elevation b.c. nodes DO J = 1,NETAP(I) INDX = OBNODE_LG(J,I) WRITE(18,'(I12)') INDX ! Global open boundary node index ENDDO C--Write the Global indexes of all Elevation Stations in local node order C write global index as positive if a resident node and negative C if a ghost node WRITE(18,3004) abs(NSTAE), NSTAE_MAX, NSTAEP(I) ! number of Global Elevation Stations DO J = 1,NSTAEP(I) INDX = IMAP_STAE_LG(J,I) WRITE(18,'(I12)') INDX ! Global station number ENDDO C--Write the Global indexes of all Velocity Stations in local node order C write global index as positive if a resident node and negative C if a ghost node WRITE(18,3005) abs(NSTAV), NSTAV_MAX, NSTAVP(I) ! number of Global Velocity Stations DO J = 1,NSTAVP(I) INDX = IMAP_STAV_LG(J,I) WRITE(18,'(I12)') INDX ! Global station number ENDDO C--Write the Global indexes of all Elevation Stations in local node order C write global index as positive if a resident node and negative C if a ghost node WRITE(18,3006) abs(NSTAM), NSTAM_MAX, NSTAMP(I) ! number of Global Meteorlogical Stations DO J = 1,NSTAMP(I) INDX = IMAP_STAM_LG(J,I) WRITE(18,'(I12)') INDX ! Global station number ENDDO C--Write the Global indexes of all Concentration Stations in local node order C write global index as positive if a resident node and negative C if a ghost node WRITE(18,3007) abs(NSTAC), NSTAC_MAX, NSTACP(I) ! number of Global Concentration Stations DO J = 1,NSTACP(I) INDX = IMAP_STAC_LG(J,I) WRITE(18,'(I12)') INDX ! Global station number ENDDO C--------------------------------------------------------------------------------- C--------------------------------------------------------------------------------- C--------------------------------------------------------------------------------- C C--Write the Resident Node List C WRITE(18,3010) (I-1),NOD_RES_TOT(I) WRITE(18,1130) (RES_NODE(J),J=1,ITOT) C C--Write the Number of Communicating PEs C WRITE(18,3020) NUM_COMM_PE(I) C C--Write the Receive List C ! loop over this subdomain's neighbors DO J = 1,NUM_COMM_PE(I) ! get the subdomain number of the Jth neighbor ! of this subdomain IPR = COMM_PE_NUM(J,I) ! zero out the total number of ghost nodes on this ! subdomain that are residents on the Jth neighbor ! of this subdomain IRECV_TOT(J,I) = 0 ! loop over nodes in this subdomain DO K = 1,NNODP(I) ! get corresponding fulldomain node number INDX = IMAP_NOD_LG(K,I) ! if the fulldomain node is a ghost and is a resident ! of the Jth neighbor of this subdomain IF (IMAP_NOD_GL(1,INDX).EQ.IPR) THEN ! increment the total number of ghost nodes that ! are residents of the Jth neighbor subdomain IRECV_TOT(J,I) = IRECV_TOT(J,I) + 1 ! record the local node number of this subdomain ! that will receive data IRECV(IRECV_TOT(J,I)) = K c uncomment next line and comment preceding line for debugging c IRECV(IRECV_TOT(J,I)) = INDX ENDIF ENDDO WRITE(18,3030) (IPR-1), IRECV_TOT(J,I) WRITE(18,1130) (IRECV(K),K=1,IRECV_TOT(J,I)) ENDDO C C--write the send list C ! loop over this subdomain's neighbors DO J = 1,NUM_COMM_PE(I) ! get the subdomain number of the Jth neighbor ! of this subdomain IPR = COMM_PE_NUM(J,I) ISEND_TOT(J,I) = 0 ! loop over nodes in the Jth neighbor subdomain DO K = 1,NNODP(IPR) ! get the fulldomain node number in the Jth neighbor subdomain INDX = IMAP_NOD_LG(K,IPR) ! if the node is a resident of this subdomain IF (IMAP_NOD_GL(1,INDX).EQ.I) THEN ! increment the total number of nodes on this subdomain ! that are ghosts on the Jth neighbor ISEND_TOT(J,I) = ISEND_TOT(J,I) + 1 ! record the local node number on this subdomain ! that will send data ISEND(ISEND_TOT(J,I)) = IMAP_NOD_GL(2,INDX) c uncomment next line and comment preceding line for debugging c ISEND(ISEND_TOT(J,I)) = INDX ENDIF ENDDO WRITE(18,3040) IPR-1, ISEND_TOT(J,I) WRITE(18,1130) (ISEND(K),K=1,ISEND_TOT(J,I)) ENDDO C IF (C3D.eqv..true.) THEN C jgf49.43.18: Add 3D station mappings from subdomain to fulldomain C to accomodate globalio. C C Write the fulldomain station numbers of all 3D density stations C in local node order; write the fulldomain station number as positive C for resident stations and negative for ghost stations. WRITE(18,3060) NSTA3DD, MAXVAL(NNSTA3DDP), NNSTA3DDP(I) DO J=1,NNSTA3DDP(I) WRITE(18,1131) IMAP_STA3DD_LG(J,I) END DO C 3D velocity stations WRITE(18,3061) NSTA3DV, MAXVAL(NNSTA3DVP), NNSTA3DVP(I) DO J=1,NNSTA3DVP(I) WRITE(18,'(I12)') IMAP_STA3DV_LG(J,I) END DO C 3D turbulence stations WRITE(18,3062) NSTA3DT, MAXVAL(NNSTA3DTP), NNSTA3DTP(I) DO J=1,NNSTA3DTP(I) WRITE(18,'(I12)') IMAP_STA3DT_LG(J,I) ENDDO ENDIF C CLOSE(18) C 1000 CONTINUE C C--Compute the surface to volume ratio (in %) C DO I = 1,NPROC ITOT = 0 DO J = 1,NUM_COMM_PE(I) ITOT = ITOT + IRECV_TOT(J,I) ENDDO PROC_SV(I) = (ITOT/REAL(NOD_RES_TOT(I)))*100.0 c WRITE(6,*) I-1,PROC_SV(I) ENDDO C print *, " " print *, "Communication Data" print *, "DOMAIN COMM_PE %(SURF/VOL)" print *, "------ ------- -----------" DO I=1, NPROC PE(1:6) = 'PE0000' CALL IWRITE(PE,3,6,I-1) WRITE(6,92) PE, NUM_COMM_PE(I),PROC_SV(I) ENDDO deallocate( res_node ) nbytes = 4*mnpp call memory_dealloc(nbytes) call memory_status() RETURN C 92 FORMAT(1X,A6,2X,I7,2X,F8.2) 1130 FORMAT(8X,6I12) !(8X,9I8) 1131 FORMAT(:,I12) Casey 100209: Changed I8 to I12 through this section. 3000 FORMAT('NELG ',3I12) 3001 FORMAT('NNODG ',3I12) 3002 FORMAT('NFLUXF ',I12) 3003 FORMAT('NETA ',3I12) 3004 FORMAT('NSTAE ',3I12) 3005 FORMAT('NSTAV ',3I12) 3006 FORMAT('NSTAM ',3I12) 3007 FORMAT('NSTAC ',3I12) 3010 FORMAT('RES NODE',2I12) 3020 FORMAT('COMM PE ',2I12) 3030 FORMAT('RECV PE ',2I12) 3040 FORMAT('SEND PE ',2I12) 3050 FORMAT('FileFmt ',3I12) 3060 FORMAT('NSTA3DD ',3I12) 3061 FORMAT('NSTA3DV ',3I12) 3062 FORMAT('NSTA3DT ',3I12) END SUBROUTINE PREP18 SUBROUTINE PREP19() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C ( Serial Version 2/28/98 ) C C This routine writes a Local "Aperiodic Elevation Boundary Condtions" C C (fort.19) file for each subdomain using the domain decomposition of C C the ADCIRC grid created by the routine DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 34.03 C C C jgf45.12 Added subroutine call to open files. C C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,IPROC,EOF INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if files opened without errors CHARACTER*40 ETIMINC,ESBINP CHARACTER*40,ALLOCATABLE :: ESBIN(:) C C--Enter, Locate, Open, and Read the ADCIRC UNIT 19 C Global Aperiodic Elevation Boundary Conditions file C C Open full domain and subdomain fort.19 files CALL OpenPrepFiles(19, 'aperiodic elevation boundary ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 19 files not preprocessed.' RETURN ! note early return ENDIF C C--Allocate local arrays C ALLOCATE ( ESBIN(MNETA) ) nbytes = 8*mneta call memory_alloc(nbytes) C READ(19,40) ETIMINC DO IPROC = 1,NPROC WRITE(SDU(IPROC),40) ETIMINC ENDDO C C--While ( NOT EOF ) Read NETA BCs from Global File C DO WHILE(.true.) DO I=1, NETA READ(19,40,iostat=eof) ESBIN(I) IF (eof.ne.0) EXIT ENDDO C EOF reached, lets exit IF (eof < 0) EXIT DO IPROC= 1,NPROC DO I=1, NETAP(IPROC) ESBINP = ESBIN(OBNODE_LG(I,IPROC)) WRITE(SDU(IPROC),40) ESBINP ENDDO ENDDO C ENDDO C C--Close Global file and all the Local Files C CLOSE (19) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO deallocate( esbin ) nbytes = 8*mneta call memory_dealloc(nbytes) call memory_status() RETURN 40 FORMAT(A40) END SUBROUTINE PREP19 C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 2 0 C--------------------------------------------------------------------------- C C jgf45.12 This subroutine will break up the full domain aperiodic C flux boundaries into subdomains using the domain decomposition of C the ADCIRC grid created by the routine DECOMP. C C -Written by MEB 04/01/04 C -Added by jgf to 45.06 10/07/2005 C -jgf45.12 Rewritten to correct bugs in subdomain fort.20 C formatting as well as the erroneous use of the GL mapping instead C of GL2. Also added subroutine call to open files. C C--------------------------------------------------------------------------- SUBROUTINE PREP20(sponge) C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE integer :: nbytes = 0 INTEGER IPROC INTEGER INDEX14, I, FLUX_NUM REAL(SZ) FLUX_INC, FLUX_VAL CHARACTER(80) :: FLUX_MSG INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error LOGICAL,optional :: sponge !.true. if want to prep fort.2001 INTEGER INDX ! full domain node number for a flow boundary node INTEGER J ! counter for subdomains that corrsp. to a single f.d. node INTEGER IPROC2! PE of a subdomain that matches a single full domain node INTEGER PROC_NO ! proc number is 20 unless specified proc_no = 20; FLUX_NUM = EXIST_FLUX C Open full domain and subdomain fort.20 files if (sponge) then proc_no = 2001 FLUX_NUM = ubound(nodeNumSP,1) write(*,*) 'FLUX_NUM = ',FLUX_NUM endif CALL OpenPrepFiles(proc_no, 'aperiodic flux boundary ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 20 files not preprocessed.' RETURN ! note early return ENDIF c c Write Increment into all flux files c READ(proc_no,*) FLUX_INC DO IPROC=1,NPROC WRITE(SDU(IPROC),*) FLUX_INC ENDDO C C jgf45.12 Write each full domain nodal flux value into each of the C subdomains that that full domain node maps to. The full domain C node may map to more than one subdomain node if it falls on a C boundary between subdomains (ghost nodes). C 33 DO I = 1, FLUX_NUM ! loop through full domain flow nodes ! READ(20,*,END=40) FLUX_VAL ! get a flo val for this f.d. flow node READ(proc_no,'(A80)',END=40) FLUX_MSG ! get a flo val for this f.d. flow node if (sponge) then INDX = nodeNumSP(I) else INDX = FLUX14_ARY(I) ! get full domain flow node number endif DO J=1, ITOTPROC(INDX) ! loop over subdomains for 1 f.d. node IPROC2 = IMAP_NOD_GL2(2*(J-1)+1,INDX) ! find next subdomain DO IPROC=1, NPROC IF (IPROC.EQ.IPROC2) THEN ! full domain node maps to this s.d. !WRITE(SDU(IPROC),50) FLUX_VAL WRITE(SDU(IPROC),*) TRIM(FLUX_MSG) ENDIF END DO END DO END DO GOTO 33 40 CLOSE (proc_no) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO IF (allocated(FLUX14_ARY)) then DEALLOCATE (FLUX14_ARY) nbytes = 4*exist_flux call memory_dealloc(nbytes) ENDIF call memory_status() return 50 FORMAT (F16.8,1x,I6,1x,I6,1x,I6) c---------------------------------------------------------------------------- END SUBROUTINE PREP20 c---------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 8 8 C--------------------------------------------------------------------------- C C kmd49 This subroutine will break up the full domain elevation C changes due to the river boundary information being above mean C sea level. It writes the fort.88 file into each subdomain using C the ADCIRC grid created by the routine DECOMP. C C - added as part of Evan's changes for rivers above MSL. C C TCM v51.24 -- Added the decomposition for a max of 256 subdomains C at a time ... some platforms/compilers limit the number of files that C can be open at any one time. C TCM v51.27 -- Commented out, as the fort.88 river elevation has C now been made a nodal attritube C--------------------------------------------------------------------------- ! SUBROUTINE PREP88() ! USE PRE_GLOBAL ! use memory_usage !C ! IMPLICIT NONE ! integer :: nbytes = 0 ! INTEGER I,J,IPROC ! INTEGER SDU(NPROC) ! subdomain unit numbers ! LOGICAL Success ! .true. if files opened without errors ! INTEGER :: NODP ! CHARACTER*80 :: et_tempsWSE ! CHARACTER*80,ALLOCATABLE :: et_SWSE(:) ! INTEGER, PARAMETER :: maxOpenFiles = 256 ! INTEGER startProc ! INTEGER endProc ! INTEGER deltaProc !C !C Perform decomposition over range of subdomains. ! startProc = 1 ! DO WHILE ( startProc .lt. nproc ) ! deltaProc = nproc - startProc ! IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles ! endProc = startProc + deltaProc ! !C Open full domain and subdomain fort.88 files. ! CALL OpenPrepFiles(88, ' river elevation data ', ! & startProc, endProc, SDU, Success) ! ! IF (.not.Success) THEN ! WRITE(*,*) 'WARNING: Unit 88 files not preprocessed.' ! RETURN ! note early return ! ENDIF ! ! ALLOCATE(et_SWSE(NNODG)) ! DO I=1, NNODG ! READ(88,80,END=9999) et_SWSE(I) ! END DO ! ! DO IPROC=startProc,endProc ! DO I=1, NNODP(IPROC) ! NODP=IMAP_NOD_LG(I,IPROC) ! et_tempsWSE=et_SWSE(NODP) ! WRITE(SDU(IPROC),80) et_tempsWSE ! END DO ! END DO ! !C Close full domain and subdomain files ! CLOSE (88) ! DO iproc=startProc, endProc ! CLOSE(sdu(iproc)) ! ENDDO ! startProc = endProc + 1 ! ! DEALLOCATE(et_SWSE) ! ! WRITE(6,'(A25,A80)') ' Finished processing ', ! & 'river elevation data' ! WRITE(6,*) 'for processor range ',startProc,' to ',endProc ! ! END DO !Loop over Procs ! 80 FORMAT(A80) !9999 CLOSE(88) ! END SUBROUTINE PREP88 !C End SUBROUTINE PREP88 C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 2 2 C--------------------------------------------------------------------------- C C ( Serial Version 2/28/98 ) C C This routine reads a global external meteorology file when NWS=1,+-2, C C +-4,+-5. In each case it wites a local meteorology file of the same C C format for each subdomain using the domain decomposition of the ADCIRC C C grid created by the routine DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 43.03 C C C jgf46.02 Added subroutine call to open prep files; this provides C the user with the ability to skip the prepping of wind data files. C C jgfdebug46.02 Added NWS=45 to imitate the behavior of the v42 (IPET) C code. C C jgf46.02 Added NWS=8 to copy the wind files for the Holland model C into the subdomains. C C tcm_v49.04 Removed NWS=3 and NWS=6 to correspond with the use of a C global file rather than local. C C--------------------------------------------------------------------------- SUBROUTINE PREP22() C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE integer :: nbytes = 0 LOGICAL FOUND,DONE INTEGER I,J,IPROC,IPROC2,ILNODE,INDX,NHG,LINDEX CHARACTER*80 PBLJAGF C CHARACTER FNAME*60,LOCFN*14,CMD1*63,CMD2*7,CMD*70,INLINE*80 CHARACTER FNAME*60,CMD1*63,CMD2*7,CMD*70 CHARACTER*170 Line ! line of data from NWS=8 (Holland) file CHARACTER*270 Line19 ! line of data from NWS=19 (AsymmHollandv2.0) file INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error INTEGER,ALLOCATABLE :: NG(:) REAL(SZ),ALLOCATABLE :: WVNXG(:),WVNYG(:),PRG(:) REAL(SZ),ALLOCATABLE :: WVNXL(:),WVNYL(:),PRL(:) REAL(SZ) U,V,PR REAL(SZ) RHOWAT !jgfdebug46.02 C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. INTEGER, PARAMETER :: maxOpenFiles = 256 INTEGER startProc INTEGER endProc INTEGER deltaProc C C Allocate local work arrays C ALLOCATE ( NG(MNWP) ) nbytes = 4*mnwp call memory_alloc(nbytes) ALLOCATE ( WVNXG(MNWP),WVNYG(MNWP),PRG(MNWP) ) nbytes = 24*mnwp call memory_alloc(nbytes) ALLOCATE ( WVNXL(MNWP),WVNYL(MNWP),PRL(MNWP) ) nbytes = 24*mnwp call memory_alloc(nbytes) C C Perform decomposition over a range of subdomains. startProc = 1 DO WHILE ( startProc .lt. nproc ) deltaProc = nproc - startProc IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc C Open full domain and all subdomain fort.22 files CALL OpenPrepFiles(22, 'wind information ', & startProc, endProc, sdu, success) IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 22 files not preprocessed.' RETURN ! note early return ENDIF C C--Branch to Appropriate Code C SELECT CASE(ABS(NWS)) C ------------- CASE(1,2,5,7) C ------------- C C MAIN LOOP FOR NWS = 1, +-2,+-5,+-7 C (1) Read a record from Global Wind Stress File C (2) Use Decomp arrarys to Localize record to a subdomain C (3) Write Local Wind Stress record in same format DO ! loop forever (or until file ends) READ(22,*,END=9999) & (NG(I),WVNXG(I),WVNYG(I),PRG(I),I=1,NNODG) DO IPROC = STARTPROC, ENDPROC DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) WVNXL(I) = WVNXG(INDX) WVNYL(I) = WVNYG(INDX) PRL(I) = PRG(INDX) ENDDO DO I=1, NNODP(IPROC) WRITE(SDU(IPROC),1100) I,WVNXL(I),WVNYL(I),PRL(I) ENDDO ENDDO ENDDO C C ------- CASE(4) C ------- C MAIN LOOP FOR NWS = +- 4 ( PBL Format ) C (1) Read a record from Global Wind Stress File C (2) Use Decomp arrarys to Localize record to a subdomain C (3) Write out in PBL Format on subdomain C C--Read a wind field record from the global input file C DO READ(22,'(A80)',END=9999) PBLJAGF IF(PBLJAGF(2:2).EQ.'#') THEN DO IPROC = STARTPROC,ENDPROC WRITE(SDU(IPROC),1101) WRITE(SDU(IPROC),1100) 1,0.0,0.0,0.0 !victor didn't like this line 27/11/03 ENDDO ELSE ! vjp 27/11/03 ! rewrote this section to handle ghost-nodes C READ(PBLJAGF,'(I8,3E13.5)',END=9999) NHG,U,V,PR READ(PBLJAGF,*,END=9999) NHG,U,V,PR DO J=1, ITOTPROC(NHG) IPROC = IMAP_NOD_GL2(2*(J-1)+1,NHG) LINDEX = IMAP_NOD_GL2(2*(J-1)+2,NHG) WRITE(SDU(IPROC),1100) LINDEX,U,V,PR ENDDO ENDIF END DO C C -------- CASE(45) C -------- C jgf46.02 Convert NWS=4 winds to NWS=5 winds to imitate the Katrina C (IPET) version of the code. C C-- Read a wind field record from the global input file C DO RHOWAT=1000.0d0 CALL NWS4GET(WVNXG,WVNYG,PRG,G,RHOWAT,NNODG,DONE) C DO IPROC = STARTPROC,ENDPROC DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) WVNXL(I) = WVNXG(INDX) WVNYL(I) = WVNYG(INDX) PRL(I) = PRG(INDX) ENDDO DO I=1, NNODP(IPROC) WRITE(SDU(IPROC),1100) I,WVNXL(I),WVNYL(I),PRL(I) ENDDO ENDDO C-- If reached EOF in NWS4GET last time go close files and return C IF (DONE) GOTO 9999 ENDDO C ------------ CASE DEFAULT C ------------ print *, "NWS=",NWS," has incorrect value in PREP22" RETURN END SELECT C C--Close Global file and all the Local Files C 9999 CLOSE (22) DO IPROC=STARTPROC, ENDPROC CLOSE (SDU(IPROC)) ENDDO startProc=endProc+1 ENDDO DEALLOCATE ( NG, WVNXG, WVNYG, PRG ) DEALLOCATE ( WVNXL, WVNYL, PRL ) nbytes = 52*mnwp call memory_dealloc(nbytes) call memory_status() RETURN 60 FORMAT(A60) 170 FORMAT(A170) 270 FORMAT(A270) 1010 FORMAT(' File ',A60,/,' WAS NOT FOUND! Try again',/) 1011 FORMAT(' File ',A60,/,' WAS FOUND! Opening & Processing file',/) 1100 FORMAT(I8,3E13.5) 1101 FORMAT(' #') c---------------------------------------------------------------------------- END SUBROUTINE PREP22 c---------------------------------------------------------------------------- SUBROUTINE PREP23() USE PRE_GLOBAL C C---------------------------------------------------------------------------C C ( add MEB 03/04/03 ) C C This routine writes a Local Input file "fort.23" file for each subdomain C C using the domain decomposition of the ADCIRC grid created by the routine C C DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 34.03 C C C C---------------------------------------------------------------------------C C IMPLICIT NONE INTEGER IPROC, NHG, J, LINDEX CHARACTER*80 PBLJAGF INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error REAL(SZ) U,V C C--Open Global Wave Stress File ( UNIT 23 ) C C Open full domain and subdomain fort.23 files CALL OpenPrepFiles(23, 'wave stress ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 23 files not preprocessed.' RETURN ! note early return ENDIF C-------------------------------------------------------------------------- C--MAIN LOOP C (1) Read a record from Global Wave Stress File C (2) Use Decomp arrays to Localize record to a subdomain C (3) Write Local Wave Stress record in standard PBL format C-------------------------------------------------------------------------- C C--Read a wave field record from the global input file C--and write out to respective local fort.23 file. C 170 READ(23,'(A80)',END=9999) PBLJAGF IF(PBLJAGF(2:2).EQ.'#') THEN DO IPROC = 1,NPROC WRITE(SDU(IPROC),1101) WRITE(SDU(IPROC),1100) 1,0.0,0.0 !victor didn't like this line 27/11/03 ENDDO ELSE ! vjp 27/11/03 ! rewrote this section to handle ghost-nodes ! and changed if test from "and" to "or" READ(PBLJAGF,'(I8,2E13.5)',END=9999) NHG,U,V IF ((U.NE.0.).OR.(V.NE.0.)) THEN DO J=1, ITOTPROC(NHG) IPROC = IMAP_NOD_GL2(2*(J-1)+1,NHG) LINDEX = IMAP_NOD_GL2(2*(J-1)+2,NHG) WRITE(SDU(IPROC),1100) LINDEX,U,V ENDDO ENDIF ENDIF GOTO 170 9999 CLOSE(23) DO IPROC=1,NPROC CLOSE(SDU(IPROC)) ENDDO 1100 FORMAT(I8,2E13.5) 1101 FORMAT (' #') 99 RETURN END C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 2 4 C--------------------------------------------------------------------------- C C WJP 10/20/2016 This subroutine will break up the full domain C SAL term file into subdomains. Added into v53.dev 02.23.18 C C Follows the same formula as other prep subroutines C C--------------------------------------------------------------------------- SUBROUTINE PREP24() C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE C integer :: nbytes = 0 INTEGER i ! node loop counter INTEGER k ! constituent loop counter INTEGER ll ! line loop counter INTEGER iproc ! subdomain loop counter INTEGER sdu(nproc) ! subdomain unit number for unit 24 files INTEGER NoOfVals ! NoOfVals for each constituent (always 1) CHARACTER(len=80) header ! header comments in unit 24 files CHARACTER(len=80) ConstName ! label for constituent LOGICAL success ! .true. if all files opened successfully REAL(SZ), ALLOCATABLE :: SALTAMP(:), SALTPHS(:) C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. INTEGER, PARAMETER :: maxOpenFiles = 256 INTEGER startProc INTEGER endProc INTEGER deltaProc REAL(SZ) Frequency ! Frequency of constituent C C Perform decomposition over range of subdomains. startProc = 1 DO WHILE ( startProc .lt. nproc ) deltaProc = nproc - startProc IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc C C Open full domain and subdomain fort.24 files. CALL OpenPrepFiles(24, 'self-attraction and loading ', & startProc, endProc, sdu, success) C IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 24 files not preprocessed.' RETURN ! note early return ENDIF C C Allocate the global SAL amp and phases ALLOCATE(SALTAMP(NNODG),SALTPHS(NNODG)) nbytes = 16*NNODG call memory_alloc(nbytes) C Read info from fort.24 and write to subdomains C Loop over the number of constituents DO k=1, NTIF C Read header information from full domain unit 24 file READ(24,'(A80)') header READ(24,*) Frequency READ(24,*) NoOfVals READ(24,'(A80)') ConstName IF (ConstName(1:2) .ne. TIPOTAG(k)(1:2)) THEN WRITE(6,*) 'CONST 24 =',ConstName,'CONST 15=',TIPOTAG(K) WRITE(6,9924) 9924 FORMAT(////,1X,'!!!!!!!!!! FATAL ERROR !!!!!!!!!', & //,1X,'CONSTITUENT NAME AS ABOVE NOT RECOGNISED ' & //,1X,'OR IN THE CORRECT ORDER. ', & //,1X,'!!!!!! EXECUTION WILL NOW BE TERMINATED !!!!!!',//) CALL EXIT(1) ! We're toast ENDIF C C Write header info to the local unit 24 DO iproc=startProc, endProc WRITE(sdu(IPROC),'(A80)') header WRITE(sdu(IPROC),*) Frequency WRITE(sdu(IPROC),*) NoOfVals WRITE(sdu(IPROC),'(A80)') ConstName END DO C Read the amp and phase of the unit 24 file DO i = 1,NNODG READ(24,*) ll,SALTAMP(ll),SALTPHS(ll) ENDDO C C Write out the info to the local unit 24 DO iproc=startProc, endProc DO i = 1,NNODP(IPROC) ll = IMAP_NOD_LG(i,IPROC) WRITE(sdu(IPROC),*) LABELS(ll),SALTAMP(ll),SALTPHS(ll) ENDDO END DO END DO C C Deallocate the arrays DEALLOCATE(SALTAMP,SALTPHS) call memory_dealloc(nbytes) C C Close full domain and subdomain files CLOSE (24) DO iproc=startProc, endProc CLOSE(sdu(iproc)) ENDDO startProc = endProc + 1 END DO C call memory_status() RETURN C--------------------------------------------------------------------------- END SUBROUTINE PREP24 C---------------------------------------------------------------------------- ! DW, for preping fort.530001 abd fort.54001 used in the harmonic forcing ! in the sponge layers ! C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 5 3 5 4 C--------------------------------------------------------------------------- C C BY DEFAULT, ONLY 256 SUBDOMAINS WILL BE PREPPED AT A TIME TO AVOID C OPENING TOO MANY FILES ON CERTAIN PLATFORMS. THIS NUMBER CAN BE C CONTROLLED BY THE PARAMETER MAXOPENFILES. C C--------------------------------------------------------------------------- SUBROUTINE PREP5354( FUNIT ) C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE C INTEGER:: FUNIT INTEGER:: NCOMP integer :: nbytes = 0 INTEGER i ! node loop counter INTEGER k ! attribute loop counter INTEGER ll ! line loop counter INTEGER m ! attribute default value counter INTEGER iproc ! subdomain loop counter INTEGER sdu(nproc) ! subdomain unit number for unit 13 files INTEGER NumOfNodes ! must match the no. of nodes in grid (unit 14) INTEGER NAttr ! number of nodal attributes in the file INTEGER NumNotDefault ! number of nodes specified in the file C CHARACTER(len=80) header ! header comments in unit 13 files C CHARACTER(len=80) AttrName ! label for attribute C CHARACTER(len=80) Units ! label for physical units CHARACTER(len=80) Skipped ! data we want to skip over REAL(SZ) DefaultVal(12) ! default value of attribute INTEGER NoOfVals ! at each node for an attribute INTEGER Mode !=0 to count, =1 to write LOGICAL success ! .true. if all files opened successfully INTEGER, ALLOCATABLE :: SDNumND(:,:) ! subdomain # of nodes not default C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. INTEGER, PARAMETER :: maxOpenFiles = 256 INTEGER startProc INTEGER endProc INTEGER deltaProc INTEGER:: NBF REAL(SZ), dimension(32):: AMIGv, FFv, FACEv ! Maximum 32 Consituent CHARACTER (LEN=300):: IGNOREMSG INTEGER:: KK TYPE CARR CHARACTER (LEN=32):: NAME END TYPE CARR TYPE (CARR):: CONSTINAME(maxOpenFiles) SELECT CASE( FUNIT ) CASE (53001) NCOMP = 2 ; CASE (54001) NCOMP = 4 ; CASE DEFAULT PRINT*, "Error in PREP5354(): ", FUNIT, " is not allowed." ; CALL EXIT(1) ; END SELECT C C C Perform decomposition over range of subdomains. startProc = 1 DO WHILE ( startProc .lt. nproc ) deltaProc = nproc - startProc IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc C C Open full domain and subdomain fort.13 files. CALL OpenPrepFiles( FUNIT, 'harmonic forcing in sponge layer', & startProc, endProc, sdu, success) C IF (.not.success) THEN WRITE(*,'(A,I5,A)') 'WARNING: Unit ', FUNIT, & 'files not preprocessed.' ; RETURN ! note early return ENDIF C C Read header information from full domain unit 13 file C READ(FUNIT,*) NBF IF ( NBF > 32 ) THEN PRINT*, "Error in PREP5354(): ", NBF, " is greater 32" ; END IF DO KK = 1, NBF READ(FUNIT,*) AMIGv(KK), FFv(KK), & FACEv(KK), CONSTINAME(KK)%NAME END DO C Transcribe header information into subdomain unit 13 files DO iproc = startProc, endProc WRITE(sdu(iproc),*) NBF DO KK = 1, NBF WRITE(sdu(iproc),'(3E15.8,A)') AMIGv(KK), FFv(KK), & FACEv(KK), ' '//TRIM(CONSTINAME(KK)%NAME) ; END DO ENDDO NAttr = 1 ; ALLOCATE(SDNumND(nproc,NAttr)) nbytes = 8*nproc*NAttr ; call memory_alloc(nbytes) DO iproc=startProc,endProc DO k=1, NAttr SDNumND(iproc,k)=0 END DO END DO C We need to figure out how many nodes go into each subdomain C for each attribute. CALL process5354( FUNIT, NBF, NCOMP, 0, sdu, & SDNumND, startProc, endProc ) C C Now rewind and advance to the beginning of the data again REWIND(FUNIT) DO ll=1, NBF + 1 READ(FUNIT,*) skipped ! skip NBF + 1 lines (NBF, AMIG, ...) END DO C C Now read each of the nodal attributes and transcribe them to the C appropriate subdomain. CALL process5354( FUNIT, NBF, NCOMP, 1, sdu, & SDNumND, startProc, endProc) DEALLOCATE(SDNumND) nbytes = 8*nproc*nattr ; call memory_dealloc(nbytes) C C Close full domain and subdomain files CLOSE (FUNIT) DO iproc=startProc, endProc CLOSE(sdu(iproc)) ENDDO startProc = endProc + 1 ; END DO call memory_status() RETURN ; END SUBROUTINE PREP5354 ! ! SUBROUTINE Process5354( FUNIT, NBF, ncmp, mode, sdu, SDNumND, & startProc, endProc) USE PRE_GLOBAL IMPLICIT NONE C INTEGER,intent(in) :: FUNIT, NBF, ncmp ! number of attributes in the file INTEGER,intent(in) :: Mode !=0 to count and return, =1 to write INTEGER,intent(in),dimension(nproc) :: sdu !i/o unit number array INTEGER,intent(inout),dimension(nproc,1) :: SDNumND INTEGER,intent(in) :: startProc INTEGER,intent(in) :: endProc INTEGER NumNotDefault ! number of nodes specified in the file INTEGER NumCol ! number of values per node for an attr INTEGER NodeNum ! full domain node number INTEGER SDNode ! subdomain node number INTEGER i ! node loop counter INTEGER j ! column loop counter INTEGER k ! attribute loop counter INTEGER m ! mapping loop counter INTEGER iproc ! subdomain loop counter INTEGER iproc2 ! mapped subdomain REAL(SZ):: AttrData(NBF, 4) ! attribute data CHARACTER(len=80) Skipped ! data we want to skip over C CHARACTER (len=80):: FMT INTEGER:: ifreq, NAttr NAttr = 1 ; DO k=1, NAttr READ(FUNIT,*) NumNotDefault IF (Mode.eq.1) THEN DO iproc=startProc,endProc WRITE(sdu(iproc),*) SDNumND(iproc,k) END DO ENDIF DO i=1, NumNotDefault ! READ(FUNIT,'(I10)') NodeNum DO ifreq = 1, NBF READ(FUNIT,*) AttrData(ifreq,1:ncmp) ; END DO ! IF (ITOTPROC(NodeNum).eq.1) THEN ! iproc = IMAP_NOD_GL(1,NodeNum) IF ( (iproc.lt.startProc) .or. (iproc.gt.endProc) ) THEN CYCLE ! skip it if it does not map to our range of procs ENDIF IF (Mode.eq.0) THEN SDNumND(iproc,k) = SDNumND(iproc,k)+1 ; ! END IF IF (Mode.eq.1) THEN SDNode = IMAP_NOD_GL(2,NodeNum) ! WRITE(sdu(iproc),*) SDNode ; DO ifreq = 1, NBF WRITE(sdu(iproc),1101) (AttrData(ifreq,j),j=1,ncmp) END DO ENDIF ! ELSE ! DO m=1, ITOTPROC(NodeNum) iproc2 = IMAP_NOD_GL2(2*(m-1)+1,NodeNum) DO iproc=startProc, endProc IF (iproc.EQ.iproc2) THEN !f.d. node maps to this s.d. IF (Mode.eq.0) THEN SDNumND(iproc,k)=SDNumND(iproc,k)+1 ; ENDIF IF (Mode.eq.1) THEN SDNode = IMAP_NOD_GL2(2*(m-1)+2,NodeNum) ; WRITE(sdu(iproc),*) SDNode ; DO ifreq = 1, NBF WRITE(sdu(iproc),1101) (AttrData(ifreq,j),j=1,ncmp) END DO ENDIF ENDIF END DO END DO ! END IF END DO IF (Mode.eq.1) THEN WRITE(6,*) 'for processor range ',startProc,' to ',endProc ENDIF END DO C 1101 FORMAT(32000(E16.8)) C RETURN C--------------------------------------------------------------------------- END SUBROUTINE Process5354 C--------------------------------------------------------------------------- C END DW C C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P 141 C--------------------------------------------------------------------------- C C ( Serial Version 4/13/12 ) C C This routine reads a global external bathymetry file when NDDT=+-1,+-2. C C In each case it wites a local bathymetry file of the same C C format for each subdomain using the domain decomposition of the ADCIRC C C grid created by the routine DECOMP. C C C C The Decomposition Variables are defined in the include file adcprep.inc C C This version is compatible with ADCIRC version 50.66 C C C C TCM -v 50.66.03 Addition for time varying Bathymetry C C This routine adopted/modified from the prep22 subroutine. C C C C--------------------------------------------------------------------------- SUBROUTINE PREP141() C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE integer :: nbytes = 0 LOGICAL FOUND,DONE INTEGER I,J,IPROC,IPROC2,ILNODE,INDX,NHG,LINDEX CHARACTER*80 PBLJAGF INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error INTEGER,ALLOCATABLE :: NG(:) REAL(SZ),ALLOCATABLE :: DPG(:) !global array REAL(SZ),ALLOCATABLE :: DPL(:) !local array REAL(SZ) DPTMP C jgf48.47 Do the decomposition for a max of 256 subdomains at a C time ... some platforms/compilers limit the number of files that C can be open at any one time. INTEGER, PARAMETER :: maxOpenFiles = 256 INTEGER startProc INTEGER endProc INTEGER deltaProc C C Allocate local work arrays C ALLOCATE ( NG(MNP) ) nbytes = 4*mnp call memory_alloc(nbytes) ALLOCATE ( DPG(MNP) ) !global nbytes = 8*mnp call memory_alloc(nbytes) ALLOCATE ( DPL(MNP) ) !local nbytes = 8*mnp call memory_alloc(nbytes) C C Perform decomposition over a range of subdomains. startProc = 1 DO WHILE ( startProc .lt. nproc ) deltaProc = nproc - startProc IF ( deltaProc .gt. maxOpenFiles ) deltaProc = maxOpenFiles endProc = startProc + deltaProc C Open full domain and all subdomain fort.141 files CALL OpenPrepFiles(141, 'bathymetry information ', & startProc, endProc, sdu, success) IF (.not.success) THEN WRITE(*,*) 'WARNING: Unit 141 files not preprocessed.' RETURN ! note early return ENDIF C C--Branch to Appropriate Code C SELECT CASE(ABS(NDDT)) C ------------- CASE(1) C ------------- C C MAIN LOOP FOR NWS = +-1 C (1) Read a record from Global Bathymetry File C (2) Use Decomp arrarys to Localize record to a subdomain C (3) Write Local Bathymetry record in same format DO ! loop forever (or until file ends) READ(141,*,END=9999) & (NG(I),DPG(I),I=1,NNODG) DO IPROC = STARTPROC, ENDPROC DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) DPL(I) = DPG(INDX) ENDDO DO I=1, NNODP(IPROC) WRITE(SDU(IPROC),*) I,DPL(I) ENDDO ENDDO ENDDO C C ------- CASE(2) C ------- C MAIN LOOP FOR NWS = +- 2 ( PBL Format ) C (1) Read a record from Global Bathymetry File C (2) Use Decomp arrarys to Localize record to a subdomain C (3) Write out in PBL Format on subdomain C C--Read a bathymetry field record from the global input file C--- during the decomp phase, after each time record indicator is written (#) C--- we write a single entry (1,-99999.d0) to ensure that there will be no C--- empty records. When this file is read by ADCIRC using nddt2get, the C--- extra entry (1,-99999.d0) will be ignored, and if node 1 actually is C--- changed then it will be read regardless if it appears twice. C DO PBLJAGF(:) = ' ' READ(141,'(A80)',END=9999) PBLJAGF IF(PBLJAGF(2:2).EQ.'#') THEN DO IPROC = STARTPROC,ENDPROC WRITE(SDU(IPROC),1101) ! write a default value to ensure that no empty records ! are produced during the decomp phase (default values will be ignored by ADCIRC) WRITE(SDU(IPROC),1100) 1,-99999.d0 ENDDO ELSE READ(PBLJAGF,*,END=9999) NHG,DPTMP DO J=1, ITOTPROC(NHG) IPROC = IMAP_NOD_GL2(2*(J-1)+1,NHG) LINDEX = IMAP_NOD_GL2(2*(J-1)+2,NHG) IF ( (IPROC.GE.STARTPROC).AND. & (IPROC.LE.ENDPROC) ) THEN WRITE(SDU(IPROC),1100) LINDEX,DPTMP endif ENDDO ENDIF END DO C C ------------ CASE DEFAULT C ------------ WRITE(*,*) "NDDT = ",NDDT," has incorrect value in PREP141" RETURN END SELECT C C--Close Global file and all the Local Files C 9999 CLOSE (141) DO IPROC=STARTPROC, ENDPROC CLOSE (SDU(IPROC)) ENDDO write(*,*) " Finished processing fort.141 file" write(*,*) "for processor range ",startproc," to ",endproc startProc=endProc+1 ENDDO DEALLOCATE ( NG, DPG ) DEALLOCATE ( DPL ) nbytes = 20*mnp call memory_dealloc(nbytes) call memory_status() RETURN ! 60 FORMAT(A60) ! 170 FORMAT(A170) !270 FORMAT(A270) !1010 FORMAT(' File ',A60,/,' WAS NOT FOUND! Try again',/) !1011 FORMAT(' File ',A60,/,' WAS FOUND! Opening & Processing file',/) 1100 FORMAT(I8,E13.5) 1101 FORMAT(' #') c---------------------------------------------------------------------------- END SUBROUTINE PREP141 c---------------------------------------------------------------------------- C kmd48.33bc add in prep subroutines for 3D boundary condition files SUBROUTINE PREP35() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C C C This routine writes a Local "Residual Boundary Condtions Baroclinic" C C (fort.35) file for each subdomain using the domain decomposition of C C the ADCIRC grid created by the routine DECOMP. C C C C Added by Kendra Dresback (Aug. 18, 2007) C C---------------------------------------------------------------------------C C IMPLICIT NONE INTEGER :: nbytes = 0 INTEGER I,J,IPROC INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if files opened without errors CHARACTER*40 ETIMINC,RESBCBINP,GRIDINC CHARACTER*40,ALLOCATABLE :: RESBCBIN(:) C C--Enter, Locate, Open, and Read the ADCIRC UNIT 35 C Global Level of No Motion Boundary Conditions file for baroclinic C C Open full domain and subdomain fort.35 files C Print *, "Made it to prepping the files" CALL OpenPrepFiles(35, 'level of no motion boundary ', & 1, nproc, SDU, Success) C Print *, "Made it out of prepping the files" IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 35 files not preprocessed.' RETURN ! note early return ENDIF C C--Allocate local arrays C ALLOCATE ( RESBCBIN(MNETA) ) nbytes = 8*mneta call memory_alloc(nbytes) C C--While ( NOT EOF ) Read NETA BCs from Global File C C PRINT *, "Made it to the reading in of the 35 file" DO ! loop until end of file READ(35,40,END=9999) ETIMINC DO IPROC = 1,NPROC WRITE(SDU(IPROC),40) ETIMINC ENDDO DO I=1, NETA READ(35,40,END=9999) RESBCBIN(I) ENDDO C DO IPROC= 1,NPROC DO I=1, NETAP(IPROC) RESBCBINP = RESBCBIN(OBNODE_LG(I,IPROC)) WRITE(SDU(IPROC),40) RESBCBINP ENDDO ENDDO END DO C C C--Close Global file and all the Local Files C 9999 CLOSE (35) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO deallocate(resbcbin) nbytes = 8*mneta call memory_dealloc(nbytes) call memory_status() C 40 FORMAT(A40) C RETURN END SUBROUTINE PREP36() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C C C This routine writes a Local "Salinity Boundary Conditions Values" C C (fort.36) file for each subdomain using the domain decomposition of C C the ADCIRC grid created by the routine DECOMP. C C C C Added by Kendra Dresback (January 15, 2008) C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,IPROC INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if files opened without errors CHARACTER*40 ETIMINC,GRIDINC INTEGER :: NODP, M INTEGER,ALLOCATABLE :: NOD(:) REAL(SZ),ALLOCATABLE :: SalBC(:,:) REAL(SZ),ALLOCATABLE :: RESBCBINP(:) C C--Enter, Locate, Open, and Read the ADCIRC UNIT 36 C Global Salinity Boundary Conditions file for baroclinic C C Open full domain and subdomain fort.36 files CALL OpenPrepFiles(36, 'salinity boundary ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 36 files not preprocessed.' RETURN ! note early return ENDIF C C--Allocate local arrays C ALLOCATE ( NOD(MNETA) ) ALLOCATE ( RESBCBINP(NFEN) ) ALLOCATE ( SalBC(MNETA,NFEN) ) nbytes = 8*mneta call memory_alloc(nbytes) C C--While ( NOT EOF ) Read NETA BCs from Global File C DO ! loop until end of file READ(36,40,END=9999) ETIMINC DO IPROC = 1,NPROC WRITE(SDU(IPROC),40) ETIMINC ENDDO DO I=1, NETA READ(36,*,END=9999) NOD(I), (SalBC(I,M),M=1,NFEN) ENDDO C DO IPROC= 1,NPROC DO I=1, NETAP(IPROC) NODP = NOD(OBNODE_LG(I,IPROC)) DO M=1,NFEN RESBCBINP(M) = SalBC(OBNODE_LG(I,IPROC),M) END DO WRITE(SDU(IPROC),80) NODP, (RESBCBINP(M),M=1,NFEN) ENDDO ENDDO END DO C C C--Close Global file and all the Local Files C 9999 CLOSE (36) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO C deallocate(salbc) nbytes = 8*mneta call memory_dealloc(nbytes) call memory_status() 40 FORMAT(A40) 80 FORMAT(1X,I6,1X,32000(F11.7,2X)) C RETURN END SUBROUTINE PREP37() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C C C This routine writes a Local "Temperature Boundary Conditions Values" C C (fort.37) file for each subdomain using the domain decomposition of C C the ADCIRC grid created by the routine DECOMP. C C C C Added by Kendra Dresback (January 15, 2008) C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,IPROC INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if files opened without errors CHARACTER*40 ETIMINC INTEGER :: NODP, M INTEGER,ALLOCATABLE :: NOD(:) REAL(SZ),ALLOCATABLE :: TempBC(:,:) REAL(SZ),ALLOCATABLE :: RESBCBINP(:) C C--Enter, Locate, Open, and Read the ADCIRC UNIT 37 C Global Temperature Boundary Conditions file for baroclinic C C Open full domain and subdomain fort.37 files CALL OpenPrepFiles(37, 'temperature boundary ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 37 files not preprocessed.' RETURN ! note early return ENDIF C C--Allocate local arrays C ALLOCATE ( NOD(MNETA) ) ALLOCATE ( RESBCBINP(NFEN) ) ALLOCATE ( TempBC(MNETA,NFEN) ) nbytes = 8*mneta call memory_alloc(nbytes) C C C--While ( NOT EOF ) Read NETA BCs from Global File C DO ! loop around until the end of the file READ(37,40,END=9999) ETIMINC DO IPROC = 1,NPROC WRITE(SDU(IPROC),40) ETIMINC ENDDO DO I=1, NETA READ(37,*,END=9999) NOD(I), (TempBC(I,M),M=1,NFEN) ENDDO C DO IPROC= 1,NPROC DO I=1, NETAP(IPROC) NODP = NOD(OBNODE_LG(I,IPROC)) DO M=1,NFEN RESBCBINP(M) = TempBC(OBNODE_LG(I,IPROC),M) END DO WRITE(SDU(IPROC),80) NODP, (RESBCBINP(M),M=1,NFEN) ENDDO ENDDO END DO C C C--Close Global file and all the Local Files C 9999 CLOSE (37) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO C deallocate(TempBC) nbytes = 8*mneta call memory_dealloc(nbytes) call memory_status() 40 FORMAT(A40) 80 FORMAT(1X,I6,1X,32000(F11.7,2X)) C RETURN END SUBROUTINE PREP38() USE PRE_GLOBAL use memory_usage C C---------------------------------------------------------------------------C C C C This routine writes a Local "Temperature Boundary Conditions Values C C for the surface" (fort.38) file for each subdomain using the domain C C decomposition of the ADCIRC grid created by the routine DECOMP. C C C C Added by Kendra Dresback (October 15, 2008) C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 INTEGER I,J,IPROC INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if files opened without errors CHARACTER*40 ETIMINC,GRIDINC INTEGER :: NODP, M, NFLUX INTEGER,ALLOCATABLE :: NOD(:) REAL(SZ),ALLOCATABLE :: TopTempBC(:,:) REAL(SZ),ALLOCATABLE :: RESBCBINP(:,:) C C--Enter, Locate, Open, and Read the ADCIRC UNIT 38 C Global Salinity Boundary Conditions file for baroclinic C C Open full domain and subdomain fort.38 files CALL OpenPrepFiles(38, 'top temperature boundary ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 38 files not preprocessed.' RETURN ! note early return ENDIF C C Determine how many values are in the top temperature boundary C condition IF (BCFLAG_TEMP.EQ.1) THEN NFLUX = 1 ELSE IF (BCFLAG_TEMP.EQ.2) THEN NFLUX = 6 ELSE IF (BCFLAG_TEMP.EQ.3) THEN NFLUX = 4 END IF MNP=nnodg C C--Allocate local arrays C ALLOCATE ( NOD(MNP) ) ALLOCATE ( RESBCBINP(MNP,NFLUX) ) ALLOCATE ( TopTempBC(MNP,NFLUX) ) nbytes = 24*mnp call memory_alloc(nbytes) C C--While ( NOT EOF ) Read NETA BCs from Global File C DO ! loop until end of file READ(38,*,END=9999) (NOD(I),(TopTempBC(I,M),M=1,NFLUX),I=1,NNODG) C DO IPROC= 1,NPROC DO I=1, NNODP(IPROC) NODP = IMAP_NOD_LG(I,IPROC) DO M=1,NFLUX RESBCBINP(I,M) = TopTempBC(NODP,M) END DO WRITE(SDU(IPROC),80) I, (RESBCBINP(I,M),M=1,NFLUX) ENDDO ENDDO END DO C C C--Close Global file and all the Local Files C 9999 CLOSE (38) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO C deallocate(toptempbc) nbytes = 24*mnp call memory_dealloc(nbytes) call memory_status() 40 FORMAT(A40) 80 FORMAT(1X,I8,1X,32(F12.6,2X)) C RETURN END SUBROUTINE PREP39() C--------------------------------------------------------------------------- C C C This routine writes a Local river boundary file for the baroclnic C C simulation (fort.39) for each subdomain using the domain C C decomposition of the ADCIRC grid created by the routine DECOMP. C C C C Added by Kendra Dresback (January 14, 2010) C ! ! arash June 23 2016: RIVBCSTATIM was missing ! arash July 7: FLUX_VAL(:,:) should support both salinity and temperature if IDEN == 4, which requires an array of size 2 * NFEN C---------------------------------------------------------------------------C C USE PRE_GLOBAL use memory_usage IMPLICIT NONE integer :: nbytes = 0 INTEGER IPROC INTEGER INDEX14, I REAL(SZ) :: FLUX_INC ! arash June 23 2016 added RIVBCSTATIM REAL(SZ) :: RIVBCSTATIM REAL(SZ),ALLOCATABLE :: FLUX_VAL(:,:) INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error INTEGER INDX ! full domain node number for a flow boundary node INTEGER J,M ! counter for subdomains that corrsp. to a single f.d. node INTEGER IPROC2! PE of a subdomain that matches a single full domain node INTEGER, ALLOCATABLE :: NOD(:) REAL(SZ),ALLOCATABLE :: RESBCBINP(:) C Open full domain and subdomain fort.20 files CALL OpenPrepFiles(39, 'aperiodic river temp and salinity ', & 1, nproc, SDU, Success) IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 39 files not preprocessed.' RETURN ! note early return ENDIF ! arash debug ! write(*,*) '--------------------' ! write(*,*) 'arash: iden =', iden ! write(*,*) '--------------------' ALLOCATE ( NOD(MNVEL) ) ALLOCATE ( RESBCBINP(NFEN) ) ! arash: ! ALLOCATE ( FLUX_VAL(MNVEL,NFEN) ) ALLOCATE ( FLUX_VAL(MNP,NFEN) ) ! arash July 7 2016: account for both salinity and temperature If ( IDEN == 4 ) Then If ( Allocated(FLUX_VAL) ) Deallocate(FLUX_VAL) If ( Allocated(RESBCBINP) ) Deallocate(RESBCBINP) ! arash ! Allocate ( FLUX_VAL(MNVEL, 2*NFEN) ) Allocate ( FLUX_VAL(MNP, 2*NFEN) ) Allocate ( RESBCBINP(2*NFEN) ) End If FLUX_VAL ( : , : ) = 0.0d0 RESBCBINP ( : ) = 0.0d0 Write(*,*) 'MNVEL =', MNVEL Write(*,*) 'MNP =', MNP c c Write Increment into all flux files c READ(39,*) FLUX_INC, RIVBCSTATIM DO IPROC=1,NPROC ! arash June 23 2016 added RIVBCSTATIM WRITE(SDU(IPROC),*) FLUX_INC, RIVBCSTATIM ENDDO C C jgf45.12 Write each full domain nodal flux value into each of the C subdomains that that full domain node maps to. The full domain C node may map to more than one subdomain node if it falls on a C boundary between subdomains (ghost nodes). C DO ! continue to loop over file until you reach the end of the file DO I=1, EXIST_BC_TS ! loop through full domain flow nodes INDX=BCTS14_ARY(I) !write(*,*) indx ! arash July 7 2016: If ( IDEN == 4 ) Then READ(39,*,END=40) (FLUX_VAL(INDX,M),M=1,2*NFEN) Else READ(39,*,END=40) (FLUX_VAL(INDX,M),M=1,NFEN) End If END DO DO I=1, EXIST_BC_TS INDX = BCTS14_ARY(I) ! get full domain flow node number DO J=1, ITOTPROC(INDX) ! loop over subdomains for 1 f.d. node IPROC2 = IMAP_NOD_GL2(2*(J-1)+1,INDX) ! find next subdomain DO IPROC=1, NPROC IF (IPROC.EQ.IPROC2) THEN ! full domain node maps to this s.d. ! arash July 7 2016: ---------------------------- If ( IDEN == 4 ) Then DO M=1,2*NFEN RESBCBINP(M) = FLUX_VAL(INDX,M) END DO WRITE(SDU(IPROC),80) (RESBCBINP(M),M=1,2*NFEN) Else DO M=1,NFEN RESBCBINP(M) = FLUX_VAL(INDX,M) END DO WRITE(SDU(IPROC),80) (RESBCBINP(M),M=1,NFEN) End If ! ----------------------------------------------- ENDIF END DO END DO END DO END DO 40 CLOSE (39) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO IF (allocated(BCTS14_ARY)) then DEALLOCATE (BCTS14_ARY) nbytes = 4*exist_bc_ts call memory_dealloc(nbytes) ENDIF call memory_status() return 80 FORMAT(1X,32000(F11.7,2X)) c---------------------------------------------------------------------------- END SUBROUTINE PREP39 c---------------------------------------------------------------------------- C kmd48.33bc add information for initial condition file SUBROUTINE HOTINITCOND() USE PRE_GLOBAL use presizes; use memory_usage C C---------------------------------------------------------------------------C C written 10/11/01 by RL C C started mods for harmonic analysis and 3D RL 5/22/03 C C jgf Updated for v45.06 09/07/2005 not incl. harmonic or 3D C C kmd Updated for v48.33 07/07/2008 to bring in initial conditions C C C C This routine reads the global initial condition file (fort.17) C C and writes local hot start files of the same format. C C C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 LOGICAL FOUND INTEGER I,J,IPROC,IINDX,IHOTSTP, not_active INTEGER IMHSF,ITHSF CHARACTER FNAME*60,LOCFN*14 CHARACTER*16 FNAME1 CHARACTER*8 FNAM8(2) EQUIVALENCE (FNAM8(1),FNAME1) INTEGER,ALLOCATABLE :: LOC2(:),NOFF(:), domA(:) REAL(SZ),ALLOCATABLE :: ETA1(:),ETA2(:),EtaDisc(:), & UU2(:),VV2(:),CH1(:) REAL(8) TIMEHSF integer :: InputFileFmtVn, NP_G_IN, NE_G_IN, NP_A_IN, NE_A_IN CHARACTER*60 FileFmtVn INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error #if 0 ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet INTEGER INZ,INF,IMM,INP,INSTAE,INSTAV,IISTAE,IISTAV,IIGLOE,IIGLOV, & IICALL,INFREQ,ITUD,NTSTEPS INTEGER ITHAS,ITHAF,ITMV,IHABEG,ICHA CHARACTER*10,ALLOCATABLE :: INAMEFR(:) REAL(8) TIMEUD REAL(SZ),ALLOCATABLE :: HA(:,:) REAL(SZ),ALLOCATABLE :: ELAV(:),ELVA(:),XVELAV(:),XVELVA(:), & YVELAV(:),YVELVA(:) REAL(SZ),ALLOCATABLE :: IFREQ(:),IFF(:),IFACE(:) REAL(SZ),ALLOCATABLE :: GLOELV(:,:) REAL(SZ),ALLOCATABLE :: GLOULV(:,:),GLOVLV(:,:) REAL(SZ),ALLOCATABLE :: STAELV(:,:) REAL(SZ),ALLOCATABLE :: STAULV(:,:),STAVLV(:,:) #endif C C-- Open the Initial Condition Start File based on the value of IHOT from C-- the fort.15 file C C Open full domain and subdomain fort.17 files Print *, "Made it to prepping the files" CALL OpenPrepFiles(17, 'initial condition file ', & 1, nproc, SDU, Success) Print *, "Made it out of prepping the files" IF (.not.Success) THEN WRITE(*,*) 'WARNING: Unit 17 files not preprocessed.' RETURN ! note early return ENDIF IHOT=17 C-- Read in info from global initial condition file READ(IHOT,*) FileFmtVn READ(IHOT,*) IMHSF READ(IHOT,*) TIMEHSF READ(IHOT,*) ITHSF READ(IHOT,*) NP_G_IN READ(IHOT,*) NE_G_IN READ(IHOT,*) NP_A_IN READ(IHOT,*) NE_A_IN if (nnodg == np_g_in) then MNP = nnodg else print *, "number global nodes does not match hotstart file" write(*,'(A,I8)') "expected value = ", nnodg write(*,'(A,I8)') "hotstart value = ", np_g_in CALL EXIT(1) endif if (nelg == ne_g_in) then MNE = nelg else print *, "number global elements does not match hotstart file" write(*,'(A,I8)') "expected value = ", nelg write(*,'(A,I8)') "hotstart value = ", ne_g_in CALL EXIT(1) endif C C Allocate local work arrays C MNP = nnodg MNE = nelg nbytes = 4*nproc call memory_alloc(nbytes) ALLOCATE ( ETA1(MNP),ETA2(MNP),EtaDisc(MNP),UU2(MNP), & VV2(MNP),NODECODE(MNP),CH1(MNP) ) nbytes = 7*mnp call memory_alloc(nbytes) ALLOCATE ( NOFF(MNE) ) nbytes = 4*mne call memory_alloc(nbytes) #if 0 ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet ALLOCATE ( HA(2*MNHARF,2*MNHARF) ) nbytes = 32*mnharf call memory_alloc(nbytes) ALLOCATE ( GLOELV(2*MNHARF,MNP) ) nbytes = 16*mnharf*mnp call memory_alloc(nbytes) ALLOCATE ( GLOULV(2*MNHARF,MNP),GLOVLV(2*MNHARF,MNP) ) nbytes = 32*mnharf*mnp call memory_alloc(nbytes) ALLOCATE ( STAELV(2*MNHARF,MNSTAE) ) nbytes = 16*mnharf*mnstae call memory_alloc(nbytes) ALLOCATE ( STAULV(2*MNHARF,MNSTAV),STAVLV(2*MNHARF,MNSTAV) ) nbytes = 16*mnharf*mnstav call memory_alloc(nbytes) ALLOCATE ( ELAV(MNP),ELVA(MNP) ) nbytes = 16*mnp call memory_alloc(nbytes) ALLOCATE ( XVELAV(MNP),XVELVA(MNP),YVELAV(MNP),YVELVA(MNP) ) nbytes = 32*mnp call memory_alloc(nbytes) ALLOCATE ( IFREQ(MNHARF),IFF(MNHARF),IFACE(MNHARF) ) nbytes = 12*mnharf call memory_alloc(nbytes) ALLOCATE ( INAMEFR(MNHARF) ) nbytes = 4*mnharf call memory_alloc(nbytes) #endif ! Continue reading global initial condition file print *, "continuing to read global initial condition file" write(*,*) "enter number of layers: " read(*,*) NFEN DO I=1,MNP READ(IHOT,*) ETA1(I) END DO DO I=1,MNP READ(IHOT,*) ETA2(I) END DO DO I=1,MNP READ(IHOT,*) UU2(I) END DO DO I=1,MNP READ(IHOT,*) VV2(I) END DO IF(IM.EQ.10) THEN DO I=1,MNP IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) CH1(I) END DO ENDIF DO I=1,MNP READ(IHOT,*) NODECODE(I) END DO DO I=1,MNE READ(IHOT,*) NOFF(I) END DO PRINT *, "Made it through the 2D values" ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet C jgf46.02 Read in 3D hotstart data if appropriate IF (IMHSF.GT.10) THEN PRINT *, "set to go into 3D read" PRINT *, "NFEN = ", NFEN CALL ReadInitCond3D(IHOT) ENDIF #if 0 C C.....DETERMINE HARMONIC ANALYSIS PARAMETERS IHARIND=NHARFR*(NHASE+NHASV+NHAGE+NHAGV) IF(IHARIND.GT.0) IHARIND=1 C.....IF HARMONIC ANALYSIS IS INCLUDED IN THE RUN, PROCESS HOT START INFORMATION FOR C.....IN PROGRESS HARMONIC ANALYSIS IF(IHARIND.EQ.1) THEN ITHAS=INT((THAS-STATIM)*(86400.D0/DT) + 0.5d0) ITHAF=INT((THAF-STATIM)*(86400.D0/DT) + 0.5d0) ITMV = ITHAF - (ITHAF-ITHAS)*FMV IHABEG=ITHAS+NHAINC C.......IF HARMONIC ANALYSIS HAS ALREADY BEGUN, READ IN HOT START C........HARMONIC ANALYSIS, MEAN AND SQUARE INFO IF(ITHSF.GT.ITHAS) THEN IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) ICHA ENDIF IF(ITHSF.GE.IHABEG) THEN READ(IHOT,REC=IHOTSTP+1) INZ READ(IHOT,REC=IHOTSTP+2) INF READ(IHOT,REC=IHOTSTP+3) IMM READ(IHOT,REC=IHOTSTP+4) INP READ(IHOT,REC=IHOTSTP+5) INSTAE READ(IHOT,REC=IHOTSTP+6) INSTAV READ(IHOT,REC=IHOTSTP+7) IISTAE READ(IHOT,REC=IHOTSTP+8) IISTAV READ(IHOT,REC=IHOTSTP+9) IIGLOE READ(IHOT,REC=IHOTSTP+10) IIGLOV READ(IHOT,REC=IHOTSTP+11) IICALL READ(IHOT,REC=IHOTSTP+12) INFREQ IHOTSTP = IHOTSTP+12 DO I=1,INFREQ+INF READ(IHOT,REC=IHOTSTP+1) FNAM8(1) READ(IHOT,REC=IHOTSTP+2) FNAM8(2) IHOTSTP = IHOTSTP + 2 INAMEFR(I) = FNAME1 READ(IHOT,REC=IHOTSTP+1) IFREQ(I) READ(IHOT,REC=IHOTSTP+2) IFF(I) READ(IHOT,REC=IHOTSTP+3) IFACE(I) IHOTSTP = IHOTSTP + 3 ENDDO READ(IHOT,REC=IHOTSTP+1) TIMEUD READ(IHOT,REC=IHOTSTP+2) ITUD IHOTSTP = IHOTSTP + 2 DO I=1,IMM DO J=1,IMM IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) HA(I,J) ENDDO ENDDO IF(NHASE.ne.0) THEN DO J=1,INSTAE DO I=1,IMM IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) STAELV(I,J) ENDDO ENDDO ENDIF IF(NHASV.ne.0) THEN DO J=1,INSTAV DO I=1,IMM READ(IHOT,REC=IHOTSTP+1) STAULV(I,J) READ(IHOT,REC=IHOTSTP+2) STAVLV(I,J) IHOTSTP = IHOTSTP + 2 ENDDO ENDDO ENDIF IF(NHAGE.ne.0) THEN DO J=1,INP DO I=1,IMM IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) GLOELV(I,J) ENDDO ENDDO ENDIF IF(NHAGV.ne.0) THEN DO J=1,INP DO I=1,IMM READ(IHOT,REC=IHOTSTP+1) GLOULV(I,J) READ(IHOT,REC=IHOTSTP+2) GLOVLV(I,J) IHOTSTP = IHOTSTP + 2 ENDDO ENDDO ENDIF ENDIF IF((FMV.GT.0.).AND.(INFREQ.GT.0).AND.(IM.EQ.0)) THEN !include means and variances IF(ITHSF.GT.ITMV) THEN IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) NTSTEPS IF(NHAGE.EQ.1) THEN DO I=1,INP READ(IHOT,REC=IHOTSTP+1) ELAV(I) READ(IHOT,REC=IHOTSTP+2) ELVA(I) IHOTSTP=IHOTSTP+2 ENDDO ENDIF IF(NHAGV.EQ.1) THEN DO I=1,INP READ(IHOT,REC=IHOTSTP+1) XVELAV(I) READ(IHOT,REC=IHOTSTP+2) YVELAV(I) READ(IHOT,REC=IHOTSTP+3) XVELVA(I) READ(IHOT,REC=IHOTSTP+4) YVELVA(I) IHOTSTP=IHOTSTP+4 ENDDO ENDIF ENDIF ENDIF ! charmv ENDIF ! HARIND #endif C C--Open All Local Hot Start files C ALLOCATE ( LOC2(NPROC) ) DO IPROC = 1,NPROC LOC2(IPROC) = 105 + (IPROC-1) LOCFN(1:14) = 'PE0000/'//FNAME(1:7) CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN (LOC2(IPROC),FILE=LOCFN) ENDDO C C--Write out info to local hot start files C DO IPROC = 1,NPROC WRITE(LOC2(IPROC),*) FileFmtVn WRITE(LOC2(IPROC),*) IMHSF WRITE(LOC2(IPROC),*) TIMEHSF WRITE(LOC2(IPROC),*) ITHSF WRITE(LOC2(IPROC),*) NNODP(IPROC) WRITE(LOC2(IPROC),*) NELP(IPROC) WRITE(LOC2(IPROC),*) NNODP(IPROC) WRITE(LOC2(IPROC),*) NELP(IPROC) DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) ETA1(IINDX) END DO DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) ETA2(IINDX) END DO DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) UU2(IINDX) END DO DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) VV2(IINDX) END DO IF(IM.EQ.10) THEN DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) CH1(IINDX) END DO ENDIF DO I=1, NNODP(IPROC) IINDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),*) NODECODE(IINDX) END DO DO I=1,NELP(IPROC) IINDX=ABS(IMAP_EL_LG(I,IPROC)) WRITE(LOC2(IPROC),*) NOFF(IINDX) END DO C C jgf46.02 Write out 3D hotstart data if appropriate IF (IMHSF.GT.10) THEN CALL WriteInitCond3D(LOC2(IPROC),IPROC) ENDIF #if 0 C C....IF APPROPRIATE, WRITE OUT HOT START INFORMATION FOR IN PROGRESS HARMONIC ANALYSIS c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITHAS)) THEN c WRITE(LOC2(IPROC),REC=IHOTSTP+1) ICHA c IHOTSTP = IHOTSTP + 1 c CALL HAHOUT(NP,NSTAE,NSTAV,NHASE,NHASV,NHAGE,NHAGV, c & LOC2(IPROC),IHOTSTP) c c IF(NHASE.EQ.1) CALL HAHOUTES(NSTAE,LOC2(IPROC),IHOTSTP) c IF(NHASV.EQ.1) CALL HAHOUTVS(NSTAV,LOC2(IPROC),IHOTSTP) c IF(NHAGE.EQ.1) CALL HAHOUTEG(MNP,LOC2(IPROC),IHOTSTP) c IF(NHAGV.EQ.1) CALL HAHOUTVG(MNP,LOC2(IPROC),IHOTSTP) c ENDIF c c if(CHARMV) then c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITMV)) THEN c IHOTSTP=IHOTSTP+1 c WRITE(LOC2(IPROC),REC=IHOTSTP) NTSTEPS c IF(NHAGE.EQ.1) THEN c DO I=1, NNODP(IPROC) c IINDX = IMAP_NOD_LG(I,IPROC) c DO I=1,MNP c WRITE(LOC2(IPROC),REC=IHOTSTP+1) ELAV(IINDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+2) ELVA(IINDX) c IHOTSTP=IHOTSTP+2 c END DO c ENDIF c IF(NHAGV.EQ.1) THEN c DO I=1,NNODP(IPROC) c WRITE(LOC2(IPROC),REC=IHOTSTP+1) XVELAV(IINDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+2) YVELAV(IINDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+3) XVELVA(IINDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+4) YVELVA(IINDX) c IHOTSTP=IHOTSTP+4 c END DO c ENDIF c ENDIF c ENDIF #endif ENDDO C C--Close Global file and all the Local Files C CLOSE (IHOT) DO IPROC=1, NPROC CLOSE (LOC2(IPROC)) ENDDO C DEALLOCATE ( LOC2 ) nbytes = 4*nproc call memory_dealloc(nbytes) DEALLOCATE ( ETA1, ETA2, EtaDisc, UU2, VV2, NODECODE, CH1 ) nbytes = 7*mnp call memory_dealloc(nbytes) DEALLOCATE ( NOFF ) nbytes = 6*mne call memory_dealloc(nbytes) call memory_status() C RETURN 1001 FORMAT('ERROR: The hot start file') 1010 FORMAT(' File ',A60,/,' WAS NOT FOUND! ADCPrep Terminated!!!',/) 1011 FORMAT(' File ',A60,/,' WAS FOUND! Opening & Processing file',/) 1012 FORMAT('was a nonmatching version') 1005 FORMAT('exists but cannot be opened.') 9973 FORMAT(/,1X,'!!!!!! EXECUTION WILL NOW BE TERMINATED !!!!!!',//) END SUBROUTINE HOTINITCOND SUBROUTINE HOTLOCALIZE() USE VERSION USE PRE_GLOBAL use presizes; use memory_usage C C---------------------------------------------------------------------------C C written 10/11/01 by RL C C started mods for harmonic analysis and 3D RL 5/22/03 C C jgf Updated for v45.06 09/07/2005 not incl. harmonic or 3D C C kmd48.33bc updated with 3D information C C C C This routine reads the global hot start file (either fort.67 or fort.68) C C and writes local hot start files of the same format. C C C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 LOGICAL FOUND INTEGER I,J,IPROC,INDX,IHOTSTP, not_active INTEGER IMHSF,ITHSF, NH, N CHARACTER FNAME*60,LOCFN*14 CHARACTER*16 FNAME1 CHARACTER*8 FNAM8(2) EQUIVALENCE (FNAM8(1),FNAME1) INTEGER,ALLOCATABLE :: LOC2(:),NOFF(:), domA(:) REAL(SZ),ALLOCATABLE :: ETA1(:),ETA2(:),EtaDisc(:), & UU2(:),VV2(:),CH1(:) REAL(8) TIMEHSF integer :: InputFileFmtVn, NP_G_IN, NE_G_IN, NP_A_IN, NE_A_IN INTEGER INZ,INF,IMM,INP,INSTAE,INSTAV,IISTAE,IISTAV,IIGLOE,IIGLOV, & IICALL,INFREQ,ITUD,NTSTEPS INTEGER IHARIND,ITHAS,ITHAF,ITMV,IHABEG,ICHA CHARACTER*10,ALLOCATABLE :: INAMEFR(:) REAL(8) TIMEUD REAL(SZ),ALLOCATABLE :: HA(:,:) REAL(SZ),ALLOCATABLE :: ELAV(:),ELVA(:),XVELAV(:),XVELVA(:), & YVELAV(:),YVELVA(:) REAL(SZ),ALLOCATABLE :: IFREQ(:),IFF(:),IFACE(:) REAL(SZ),ALLOCATABLE :: GLOELV(:,:) REAL(SZ),ALLOCATABLE :: GLOULV(:,:),GLOVLV(:,:) REAL(SZ),ALLOCATABLE :: STAELV(:,:) REAL(SZ),ALLOCATABLE :: STAULV(:,:),STAVLV(:,:) REAL(SZ) TIME REAL(SZ) DUMMY INTEGER IDUMMY INTEGER LUN INTEGER NHS C C-- Open Appropriate Hot Start File based on the value of IHOT from C-- the fort.15 file C write(*,*) "enter IHOT: " read(*,*) IHOT SELECT CASE (IHOT) CASE(67) FNAME='fort.67' CASE(68) FNAME='fort.68' CASE(367,368) write(*,*) "INFO: IHOT=",IHOT, & " means parallel ADCIRC should read a NetCDF hotstart file." write(*,*) & "INFO: NetCDF hotstart files do not require decomposition." RETURN CASE DEFAULT write(*,*) "ERROR: The IHOT value ",IHOT, & " is not a valid option." write(*,*) "INFO: 67 and 68 are the only valid options." RETURN END SELECT C INQUIRE(FILE=FNAME,EXIST=FOUND) IF (FOUND) THEN WRITE(*,1011) FNAME IF(IHOT.EQ.67.OR.IHOT.EQ.68) & OPEN(IHOT,FILE=FNAME,ACCESS='DIRECT',RECL=8) ELSE WRITE(*,1010) FNAME CALL EXIT(1) ENDIF C-- Read in info from global hot start files IHOTSTP=1 READ(IHOT,REC=IHOTSTP) InputFileFmtVn ; IHOTSTP = IHOTSTP + 1 if (.not. CMP_VERSION_NUMBERS(InputFileFmtVn, FileFmtVersion))then write(*, 1001) write(*, 1012) write(*, 9973) !stop endif READ(IHOT,REC=IHOTSTP) IMHSF ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) TIMEHSF ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) ITHSF ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NP_G_IN ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NE_G_IN ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NP_A_IN ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NE_A_IN ; IHOTSTP = IHOTSTP + 1 if (nnodg == np_g_in) then MNP = nnodg print *, "MNP = ", MNP else print *, "number global nodes does not match hotstart file" write(*,'(A,I8)') "expected value = ", nnodg write(*,'(A,I8)') "hotstart value = ", np_g_in CALL EXIT(1) endif if (nelg == ne_g_in) then MNE = nelg else print *, "number global elements does not match hotstart file" write(*,'(A,I8)') "expected value = ", nelg write(*,'(A,I8)') "hotstart value = ", ne_g_in CALL EXIT(1) endif PRINT *, "IMHSF ", IMHSF C C Allocate local work arrays C nbytes = 4*nproc call memory_alloc(nbytes) ALLOCATE ( ETA1(MNP),ETA2(MNP),EtaDisc(MNP),UU2(MNP), & VV2(MNP),NODECODE(MNP),CH1(MNP) ) nbytes = 7*mnp*8 call memory_alloc(nbytes) ALLOCATE ( NOFF(MNE) ) nbytes = 4*mne call memory_alloc(nbytes) ! Continue reading global hot start file print *, "continuing to read global hotstart file" DO I=1,MNP READ(IHOT,REC=IHOTSTP) ETA1(I) ; IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP READ(IHOT,REC=IHOTSTP) ETA2(I) ; IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP READ(IHOT,REC=IHOTSTP) EtaDisc(I) ; IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP READ(IHOT,REC=IHOTSTP) UU2(I) ; IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP READ(IHOT,REC=IHOTSTP) VV2(I) ; IHOTSTP = IHOTSTP + 1 END DO IF(IMHSF.EQ.10) THEN DO I=1,MNP READ(IHOT,REC=IHOTSTP) CH1(I) ; IHOTSTP = IHOTSTP + 1 END DO ENDIF DO I=1,MNP READ(IHOT,REC=IHOTSTP) NODECODE(I) ; IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNE READ(IHOT,REC=IHOTSTP) NOFF(I) ; IHOTSTP = IHOTSTP + 1 END DO READ(IHOT,REC=IHOTSTP) IESTP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUE ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IVSTP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) ICSTP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUC ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IPSTP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IWSTP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUM ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IGEP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUGE ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IGVP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUGV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IGCP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUGC ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IGPP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IGWP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) NSCOUGW ; IHOTSTP = IHOTSTP + 1 C kmd48.33 moved 3D hot start information to subroutine C and took out other lines C jgf49.17 refined check of IMHSF so that it picks up only C IM values that indicate 3D (and so we can use six integer IM values). Casey 140701: Added for 611112 and 711112. IF ((IMHSF.EQ.1).OR.(IMHSF.EQ.11).OR. C & (IMHSF.EQ.21).OR.(IMHSF.EQ.31)) THEN & (IMHSF.EQ.21).OR.(IMHSF.EQ.31).OR. & (IMHSF.EQ.611112).OR.(IMHSF.EQ.711112))THEN CALL ReadHotStart3D(IHOT,IHOTSTP) ENDIF C jgf48.03 harmonic analysis not supported yet #if 0 C C....DETERMINE HARMONIC ANALYSIS PARAMETERS IHARIND=NHARFR*(NHASE+NHASV+NHAGE+NHAGV) IF(IHARIND.GT.0) IHARIND=1 C.....IF HARMONIC ANALYSIS IS INCLUDED IN THE RUN, PROCESS HOT START C INFORMATION FOR IN PROGRESS HARMONIC ANALYSIS IF(IHARIND.EQ.1) THEN ITHAS=INT((THAS-STATIM)*(86400.D0/DT) + 0.5d0) ITHAF=INT((THAF-STATIM)*(86400.D0/DT) + 0.5d0) ITMV = ITHAF - (ITHAF-ITHAS)*FMV IHABEG=ITHAS+NHAINC C.......IF HARMONIC ANALYSIS HAS ALREADY BEGUN, READ IN HOT START C........HARMONIC ANALYSIS, MEAN AND SQUARE INFO IF(ITHSF.GT.ITHAS) THEN READ(IHOT,REC=IHOTSTP) ICHA IHOTSTP=IHOTSTP+1 ENDIF IF(ITHSF.GE.IHABEG) THEN READ(IHOT,REC=IHOTSTP) INZ ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) INF ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IMM ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) INP ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) INSTAE ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) INSTAV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IISTAE ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IISTAV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IIGLOE ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IIGLOV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IICALL ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) INFREQ ; IHOTSTP = IHOTSTP + 1 DO I=1,INFREQ+INF READ(IHOT,REC=IHOTSTP) FNAM8(1) ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) FNAM8(2) ; IHOTSTP = IHOTSTP + 1 INAMEFR(I) = FNAME1 READ(IHOT,REC=IHOTSTP) IFREQ(I) ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IFF(I) ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) IFACE(I) ; IHOTSTP = IHOTSTP + 1 ENDDO READ(IHOT,REC=IHOTSTP) TIMEUD ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) ITUD ; IHOTSTP = IHOTSTP + 1 DO I=1,IMM DO J=1,IMM READ(IHOT,REC=IHOTSTP) HA(I,J) ; IHOTSTP = IHOTSTP + 1 ENDDO ENDDO IF(NHASE.ne.0) THEN DO J=1,INSTAE DO I=1,IMM READ(IHOT,REC=IHOTSTP) STAELV(I,J) IHOTSTP=IHOTSTP+1 ENDDO ENDDO ENDIF IF(NHASV.ne.0) THEN DO J=1,INSTAV DO I=1,IMM READ(IHOT,REC=IHOTSTP) STAULV(I,J) IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) STAVLV(I,J) IHOTSTP = IHOTSTP + 1 ENDDO ENDDO ENDIF IF(NHAGE.ne.0) THEN DO J=1,INP DO I=1,IMM READ(IHOT,REC=IHOTSTP) GLOELV(I,J) IHOTSTP=IHOTSTP+1 ENDDO ENDDO ENDIF IF(NHAGV.ne.0) THEN DO J=1,INP DO I=1,IMM READ(IHOT,REC=IHOTSTP) GLOULV(I,J) IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) GLOVLV(I,J) IHOTSTP = IHOTSTP + 1 ENDDO ENDDO ENDIF ENDIF IF((FMV.GT.0.).AND.(INFREQ.GT.0).AND.(IM.EQ.0)) THEN !include means and variances IF(ITHSF.GT.ITMV) THEN READ(IHOT,REC=IHOTSTP) NTSTEPS IHOTSTP=IHOTSTP+1 IF(NHAGE.EQ.1) THEN DO I=1,INP READ(IHOT,REC=IHOTSTP) ELAV(I) IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) ELVA(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF IF(NHAGV.EQ.1) THEN DO I=1,INP READ(IHOT,REC=IHOTSTP) XVELAV(I) IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) YVELAV(I) IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) XVELVA(I) IHOTSTP=IHOTSTP+1 READ(IHOT,REC=IHOTSTP) YVELVA(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF ENDIF ENDIF ! charmv ENDIF ! HARIND #endif C C--Open All Local Hot Start files C ALLOCATE ( LOC2(NPROC) ) DO IPROC = 1,NPROC LOC2(IPROC) = 105 + (IPROC-1) LOCFN(1:14) = 'PE0000/'//FNAME(1:7) CALL IWRITE(LOCFN,3,6,IPROC-1) OPEN (LOC2(IPROC),FILE=LOCFN,ACCESS='DIRECT',RECL=8) ENDDO C C--Write out info to local hot start files C DO IPROC = 1,NPROC IHOTSTP=1 WRITE(LOC2(IPROC),REC=IHOTSTP) InputFileFmtVn ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IMHSF ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) TIMEHSF ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) ITHSF ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NNODP(IPROC) ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NELP(IPROC) ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NNODP(IPROC) ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NELP(IPROC) ; IHOTSTP = IHOTSTP + 1 DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) ETA1(INDX) IHOTSTP=IHOTSTP+1 END DO DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) ETA2(INDX) IHOTSTP=IHOTSTP+1 END DO DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) EtaDisc(INDX) IHOTSTP=IHOTSTP+1 END DO DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) UU2(INDX) IHOTSTP=IHOTSTP+1 END DO DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) VV2(INDX) IHOTSTP=IHOTSTP+1 END DO IF(IM.EQ.10) THEN DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) CH1(INDX) IHOTSTP=IHOTSTP+1 END DO ENDIF DO I=1, NNODP(IPROC) INDX = ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) NODECODE(INDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NELP(IPROC) INDX=ABS(IMAP_EL_LG(I,IPROC)) WRITE(LOC2(IPROC),REC=IHOTSTP) NOFF(INDX) IHOTSTP=IHOTSTP+1 END DO WRITE(LOC2(IPROC),REC=IHOTSTP) IESTP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUE ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IVSTP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUV ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) ICSTP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUC ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IPSTP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IWSTP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUM ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IGEP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUGE ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IGVP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUGV ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IGCP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUGC ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IGPP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) IGWP ; IHOTSTP = IHOTSTP + 1 WRITE(LOC2(IPROC),REC=IHOTSTP) NSCOUGW ; IHOTSTP = IHOTSTP + 1 C kmd48.33bc moved 3D hot start information to subroutine C jgf49.43 refined check of IMHSF so that it picks up only C IM values that indicate 3D (and so we can use six integer IM values). Casey 140701: Added for 611112 and 711112. IF ((IMHSF.EQ.1).OR.(IMHSF.EQ.11).OR. C & (IMHSF.EQ.21).OR.(IMHSF.EQ.31)) THEN & (IMHSF.EQ.21).OR.(IMHSF.EQ.31).OR. & (IMHSF.EQ.611112).OR.(IMHSF.EQ.711112))THEN CALL WriteHotStart3D(LOC2(IPROC),IHOTSTP,IPROC) ENDIF #if 0 C C....IF APPROPRIATE, WRITE OUT HOT START INFORMATION FOR IN PROGRESS HARMONIC ANALYSIS c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITHAS)) THEN c WRITE(LOC2(IPROC),REC=IHOTSTP+1) ICHA c IHOTSTP = IHOTSTP + 1 c CALL HAHOUT(NP,NSTAE,NSTAV,NHASE,NHASV,NHAGE,NHAGV, c & LOC2(IPROC),IHOTSTP) c c IF(NHASE.EQ.1) CALL HAHOUTES(NSTAE,LOC2(IPROC),IHOTSTP) c IF(NHASV.EQ.1) CALL HAHOUTVS(NSTAV,LOC2(IPROC),IHOTSTP) c IF(NHAGE.EQ.1) CALL HAHOUTEG(MNP,LOC2(IPROC),IHOTSTP) c IF(NHAGV.EQ.1) CALL HAHOUTVG(MNP,LOC2(IPROC),IHOTSTP) c ENDIF c c if(CHARMV) then c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITMV)) THEN c IHOTSTP=IHOTSTP+1 c WRITE(LOC2(IPROC),REC=IHOTSTP) NTSTEPS c IF(NHAGE.EQ.1) THEN c DO I=1, NNODP(IPROC) c INDX = IMAP_NOD_LG(I,IPROC) c DO I=1,MNP c WRITE(LOC2(IPROC),REC=IHOTSTP+1) ELAV(INDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+2) ELVA(INDX) c IHOTSTP=IHOTSTP+2 c END DO c ENDIF c IF(NHAGV.EQ.1) THEN c DO I=1,NNODP(IPROC) c WRITE(LOC2(IPROC),REC=IHOTSTP+1) XVELAV(INDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+2) YVELAV(INDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+3) XVELVA(INDX) c WRITE(LOC2(IPROC),REC=IHOTSTP+4) YVELVA(INDX) c IHOTSTP=IHOTSTP+4 c END DO c ENDIF c ENDIF c ENDIF #endif ENDDO C C--Close Global file and all the Local Files C CLOSE (IHOT) DO IPROC=1, NPROC CLOSE (LOC2(IPROC)) ENDDO C IF(ALLOCATED(LOC2)) DEALLOCATE ( LOC2 ) nbytes = 4*nproc call memory_dealloc(nbytes) IF(ALLOCATED( ETA1 ))DEALLOCATE ( ETA1 ) IF(ALLOCATED( ETA2 ))DEALLOCATE ( ETA2 ) IF(ALLOCATED( EtaDisc ))DEALLOCATE ( EtaDisc ) IF(ALLOCATED( UU2 ))DEALLOCATE ( UU2 ) IF(ALLOCATED( VV2 ))DEALLOCATE ( VV2 ) IF(ALLOCATED( NODECODE ))DEALLOCATE ( NODECODE ) IF(ALLOCATED( CH1 ))DEALLOCATE ( CH1 ) nbytes = 7*mnp*8 call memory_dealloc(nbytes) IF(ALLOCATED(NOFF))DEALLOCATE ( NOFF ) nbytes = 6*mne call memory_dealloc(nbytes) IF(ALLOCATED( DUU ))DEALLOCATE ( DUU ) IF(ALLOCATED( DUV ))DEALLOCATE ( DUV ) IF(ALLOCATED( DVV ))DEALLOCATE ( DVV ) nbytes = 3*mnp*8 call memory_dealloc(nbytes) IF(ALLOCATED( UU )) DEALLOCATE ( UU ) IF(ALLOCATED( VV )) DEALLOCATE ( VV ) nbytes = 2*mnp*8 call memory_dealloc(nbytes) IF(ALLOCATED ( BSX )) DEALLOCATE ( BSX ) IF(ALLOCATED ( BSY )) DEALLOCATE ( BSY ) nbytes = 2*mnp*8 call memory_dealloc(nbytes) IF(ALLOCATED ( WZ )) DEALLOCATE ( WZ ) IF(ALLOCATED ( q20 )) DEALLOCATE (q20 ) nbytes = (mnp*nfen*8) + (mnp*nfen*8) call memory_dealloc(nbytes) IF(ALLOCATED ( RealQ )) DEALLOCATE ( RealQ) IF(ALLOCATED ( ImagQ )) DEALLOCATE ( ImagQ) nbytes = (mnp*nfen*8) + (mnp*nfen*8) call memory_dealloc(nbytes) IF(ALLOCATED ( l )) DEALLOCATE ( l ) IF(ALLOCATED ( SigT )) DEALLOCATE ( SigT ) nbytes = (mnp*nfen*8) + (mnp*nfen*8) call memory_dealloc(nbytes) IF(ALLOCATED ( Sal)) DEALLOCATE ( Sal ) IF(ALLOCATED ( Temp )) DEALLOCATE ( Temp ) nbytes = (mnp*nfen*8) + (mnp*nfen*8) call memory_dealloc(nbytes) call memory_status() C RETURN 1001 FORMAT('ERROR: The hot start file') 1010 FORMAT(' File ',A60,/,' WAS NOT FOUND! ADCPrep Terminated!!!',/) 1011 FORMAT(' File ',A60,/,' WAS FOUND! Opening & Processing file',/) 1012 FORMAT('was a nonmatching version') 1005 FORMAT('exists but cannot be opened.') 9973 FORMAT(/,1X,'!!!!!! EXECUTION WILL NOW BE TERMINATED !!!!!!',//) END SUBROUTINE HOTLOCALIZE SUBROUTINE HOTGLOBALIZE() USE PRE_GLOBAL use presizes; use memory_usage C C---------------------------------------------------------------------------C C written 10/11/01 by RL C C started mods for harmonic analysis and 3D RL 5/22/03 C C jgf Updated for v45.06 09/07/2005 not incl. harmonic or 3D C C kmd48.33bc updated with 3D hot start C C C C This routine reads the global hot start file (either fort.67 or fort.68) C C and writes local hot start files of the same format. C C C C---------------------------------------------------------------------------C C IMPLICIT NONE integer :: nbytes = 0 LOGICAL FOUND INTEGER I,J,IPROC,INDX,IHOTSTP, not_active INTEGER IMHSF,ITHSF,IVALUE,IDUMY, NH, N CHARACTER FNAME*60,LOCFN*14 CHARACTER*16 FNAME1 CHARACTER*8 FNAM8(2) EQUIVALENCE (FNAM8(1),FNAME1) INTEGER,ALLOCATABLE :: LOC2(:),NOFF(:), domA(:) REAL(SZ),ALLOCATABLE :: ETA1(:),ETA2(:),EtaDisc(:), & UU2(:),VV2(:),CH1(:) REAL(8) TIMEHSF, RVALUE integer :: InputFileFmtVn, NP_G_IN, NE_G_IN, NP_A_IN, NE_A_IN #if 0 ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet INTEGER INZ,INF,IMM,INP,INSTAE,INSTAV,IISTAE,IISTAV,IIGLOE,IIGLOV, & IICALL,INFREQ,ITUD,NTSTEPS INTEGER IHARIND,ITHAS,ITHAF,ITMV,IHABEG,ICHA CHARACTER*10,ALLOCATABLE :: INAMEFR(:) REAL(8) TIMEUD REAL(SZ),ALLOCATABLE :: HA(:,:) REAL(SZ),ALLOCATABLE :: ELAV(:),ELVA(:),XVELAV(:),XVELVA(:), & YVELAV(:),YVELVA(:) REAL(SZ),ALLOCATABLE :: IFREQ(:),IFF(:),IFACE(:) REAL(SZ),ALLOCATABLE :: GLOELV(:,:) REAL(SZ),ALLOCATABLE :: GLOULV(:,:),GLOVLV(:,:) REAL(SZ),ALLOCATABLE :: STAELV(:,:) REAL(SZ),ALLOCATABLE :: STAULV(:,:),STAVLV(:,:) #endif C C-- Open Appropriate Hot Start File based on the value of IHOT from C-- the fort.15 file C write(*,*) "enter IHOT: " read(*,*) IHOT IF(IHOT.EQ.67) FNAME='fort.67' IF(IHOT.EQ.68) FNAME='fort.68' C C--Open All Local Hot Start files C ALLOCATE ( LOC2(NPROC) ) DO IPROC = 1,NPROC LOC2(IPROC) = 105 + (IPROC-1) LOCFN(1:14) = 'PE0000/'//FNAME(1:7) CALL IWRITE(LOCFN,3,6,IPROC-1) INQUIRE(FILE=LOCFN,EXIST=FOUND) IF (FOUND) THEN WRITE(*,1011) LOCFN OPEN (LOC2(IPROC),FILE=LOCFN,ACCESS='DIRECT',RECL=8) ELSE WRITE(*,1010) FNAME CALL EXIT(1) ENDIF ENDDO C C Allocate local work arrays C MNP = nnodg ! global number of nodes ( read from fort.18 ) print *, "MNP =", MNP nbytes = 4*nproc call memory_alloc(nbytes) ALLOCATE ( ETA1(MNP),ETA2(MNP),EtaDisc(MNP),UU2(MNP), & VV2(MNP),NODECODE(MNP),CH1(MNP) ) nbytes = 7*mnp MNE = nelg ! global number of elements ( read from fort.18 ) print *, "MNE =", MNE call memory_alloc(nbytes) ALLOCATE ( NOFF(MNE) ) nbytes = 4*mne call memory_alloc(nbytes) #if HA ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet ALLOCATE ( HA(2*MNHARF,2*MNHARF) ) nbytes = 32*mnharf call memory_alloc(nbytes) ALLOCATE ( GLOELV(2*MNHARF,MNP) ) nbytes = 16*mnharf*mnp call memory_alloc(nbytes) ALLOCATE ( GLOULV(2*MNHARF,MNP),GLOVLV(2*MNHARF,MNP) ) nbytes = 32*mnharf*mnp call memory_alloc(nbytes) ALLOCATE ( STAELV(2*MNHARF,MNSTAE) ) nbytes = 16*mnharf*mnstae call memory_alloc(nbytes) ALLOCATE ( STAULV(2*MNHARF,MNSTAV),STAVLV(2*MNHARF,MNSTAV) ) nbytes = 16*mnharf*mnstav call memory_alloc(nbytes) ALLOCATE ( ELAV(MNP),ELVA(MNP) ) nbytes = 16*mnp call memory_alloc(nbytes) ALLOCATE ( XVELAV(MNP),XVELVA(MNP),YVELAV(MNP),YVELVA(MNP) ) nbytes = 32*mnp call memory_alloc(nbytes) ALLOCATE ( IFREQ(MNHARF),IFF(MNHARF),IFACE(MNHARF) ) nbytes = 12*mnharf call memory_alloc(nbytes) ALLOCATE ( INAMEFR(MNHARF) ) nbytes = 4*mnharf call memory_alloc(nbytes) #endif C C--Read info from local hot start files C DO IPROC = 1,NPROC IHOTSTP=1 READ(LOC2(IPROC),REC=IHOTSTP) InputFileFmtVn ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IMHSF ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) TIMEHSF ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) ITHSF ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IDUMY ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IDUMY ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IDUMY ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IDUMY ; IHOTSTP = IHOTSTP + 1 DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) ETA1(INDX) = RVALUE END DO DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) ETA2(INDX) = RVALUE END DO DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) EtaDisc(INDX) = RVALUE END DO DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) UU2(INDX) = RVALUE END DO DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) VV2(INDX) = RVALUE END DO IF(IM.EQ.10) THEN DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) RVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) CH1(INDX) = RVALUE END DO ENDIF DO I=1, NNODP(IPROC) INDX = IMAP_NOD_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) IVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) NODECODE(INDX) = IVALUE END DO DO I=1,NELP(IPROC) INDX = IMAP_EL_LG(I,IPROC) READ(LOC2(IPROC),REC=IHOTSTP) IVALUE IHOTSTP=IHOTSTP+1 IF (INDX > 0) NOFF(INDX) = IVALUE END DO READ(LOC2(IPROC),REC=IHOTSTP) IESTP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUE ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IVSTP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUV ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) ICSTP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUC ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IPSTP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IWSTP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUM ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IGEP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUGE ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IGVP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUGV ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IGCP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUGC ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IGPP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) IGWP ; IHOTSTP = IHOTSTP + 1 READ(LOC2(IPROC),REC=IHOTSTP) NSCOUGW ; IHOTSTP = IHOTSTP + 1 C C kmd48.33bc add information for 3D hot start C jgf46.02 read in 3D hotstart data if appropriate IF (C3D) THEN CALL ReadHotStart3DGlobal(LOC2(IPROC),IHOTSTP,IPROC) ENDIF #if HA C C....IF APPROPRIATE, WRITE OUT HOT START INFORMATION FOR IN PROGRESS HARMONIC ANALYSIS c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITHAS)) THEN c READ(LOC2(IPROC),REC=IHOTSTP+1) ICHA c IHOTSTP = IHOTSTP + 1 c CALL HAHOUT(NP,NSTAE,NSTAV,NHASE,NHASV,NHAGE,NHAGV, c & LOC2(IPROC),IHOTSTP) c c IF(NHASE.EQ.1) CALL HAHOUTES(NSTAE,LOC2(IPROC),IHOTSTP) c IF(NHASV.EQ.1) CALL HAHOUTVS(NSTAV,LOC2(IPROC),IHOTSTP) c IF(NHAGE.EQ.1) CALL HAHOUTEG(MNP,LOC2(IPROC),IHOTSTP) c IF(NHAGV.EQ.1) CALL HAHOUTVG(MNP,LOC2(IPROC),IHOTSTP) c ENDIF c c if(CHARMV) then c IF((IHARIND.EQ.1).AND.(ITHSF.GT.ITMV)) THEN c IHOTSTP=IHOTSTP+1 c READ(LOC2(IPROC),REC=IHOTSTP) NTSTEPS c IF(NHAGE.EQ.1) THEN c DO I=1, NNODP(IPROC) c INDX = IMAP_NOD_LG(I,IPROC) c DO I=1,MNP c READ(LOC2(IPROC),REC=IHOTSTP+1) ELAV(INDX) c READ(LOC2(IPROC),REC=IHOTSTP+2) ELVA(INDX) c IHOTSTP=IHOTSTP+2 c END DO c ENDIF c IF(NHAGV.EQ.1) THEN c DO I=1,NNODP(IPROC) c READ(LOC2(IPROC),REC=IHOTSTP+1) XVELAV(INDX) c READ(LOC2(IPROC),REC=IHOTSTP+2) YVELAV(INDX) c READ(LOC2(IPROC),REC=IHOTSTP+3) XVELVA(INDX) c READ(LOC2(IPROC),REC=IHOTSTP+4) YVELVA(INDX) c IHOTSTP=IHOTSTP+4 c END DO c ENDIF c ENDIF c ENDIF #endif CLOSE (LOC2(IPROC)) ENDDO C----------------------------------------------------------------------- C-- Write info to global hot start files C----------------------------------------------------------------------- OPEN(IHOT,FILE=trim(FNAME),ACCESS='DIRECT',RECL=8) print *, "opening global hotstart file" IHOTSTP=1 WRITE(IHOT,REC=IHOTSTP) InputFileFmtVn ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IMHSF ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) TIMEHSF ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) ITHSF ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) MNP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) MNE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) MNP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) MNE ; IHOTSTP = IHOTSTP + 1 DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) ETA1(I) IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) ETA2(I) IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) EtaDisc(I) IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) UU2(I) IHOTSTP = IHOTSTP + 1 END DO DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) VV2(I) IHOTSTP = IHOTSTP + 1 END DO IF(IM.EQ.10) THEN DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) CH1(I) IHOTSTP=IHOTSTP+1 END DO ENDIF DO I=1,MNP WRITE(IHOT,REC=IHOTSTP) NODECODE(I) IHOTSTP=IHOTSTP+1 END DO DO I=1,MNE WRITE(IHOT,REC=IHOTSTP) NOFF(I) IHOTSTP=IHOTSTP+1 END DO WRITE(IHOT,REC=IHOTSTP) IESTP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IVSTP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUV ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) ICSTP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUC ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IPSTP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IWSTP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUM ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IGEP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUGE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IGVP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUGV ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IGCP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUGC ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IGPP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IGWP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) NSCOUGW ; IHOTSTP = IHOTSTP + 1 C ! vjp 2006/9/30 not supporting harmonic analysis or C3D yet C kmd48.33bc add information for 3D hot start C jgf46.02 Write in 3D hotstart data if appropriate IF (C3D) THEN CALL WriteHotStart3DGlobal(IHOT,IHOTSTP,IPROC) ENDIF C #if 0 C.....DETERMINE HARMONIC ANALYSIS PARAMETERS IHARIND=NHARFR*(NHASE+NHASV+NHAGE+NHAGV) IF(IHARIND.GT.0) IHARIND=1 C.....IF HARMONIC ANALYSIS IS INCLUDED IN THE RUN, PROCESS HOT START INFORMATION FOR C.....IN PROGRESS HARMONIC ANALYSIS IF(IHARIND.EQ.1) THEN ITHAS=INT((THAS-STATIM)*(86400.D0/DT) + 0.5d0) ITHAF=INT((THAF-STATIM)*(86400.D0/DT) + 0.5d0) ITMV = ITHAF - (ITHAF-ITHAS)*FMV IHABEG=ITHAS+NHAINC C.......IF HARMONIC ANALYSIS HAS ALREADY BEGUN, READ IN HOT START C........HARMONIC ANALYSIS, MEAN AND SQUARE INFO IF(ITHSF.GT.ITHAS) THEN WRITE(IHOT,REC=IHOTSTP) ICHA IHOTSTP=IHOTSTP+1 ENDIF IF(ITHSF.GE.IHABEG) THEN WRITE(IHOT,REC=IHOTSTP) INZ ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) INF ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IMM ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) INP ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) INSTAE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) INSTAV ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IISTAE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IISTAV ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IIGLOE ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IIGLOV ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IICALL ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) INFREQ ; IHOTSTP = IHOTSTP + 1 DO I=1,INFREQ+INF WRITE(IHOT,REC=IHOTSTP) FNAM8(1) ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) FNAM8(2) ; IHOTSTP = IHOTSTP + 1 INAMEFR(I) = FNAME1 WRITE(IHOT,REC=IHOTSTP) IFREQ(I) ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IFF(I) ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) IFACE(I) ; IHOTSTP = IHOTSTP + 1 ENDDO WRITE(IHOT,REC=IHOTSTP) TIMEUD ; IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) ITUD ; IHOTSTP = IHOTSTP + 1 DO I=1,IMM DO J=1,IMM WRITE(IHOT,REC=IHOTSTP) HA(I,J) IHOTSTP = IHOTSTP + 1 ENDDO ENDDO IF(NHASE.ne.0) THEN DO J=1,INSTAE DO I=1,IMM WRITE(IHOT,REC=IHOTSTP) STAELV(I,J) IHOTSTP=IHOTSTP+1 ENDDO ENDDO ENDIF IF(NHASV.ne.0) THEN DO J=1,INSTAV DO I=1,IMM WRITE(IHOT,REC=IHOTSTP) STAULV(I,J) IHOTSTP=IHOTSTP+1 WRITE(IHOT,REC=IHOTSTP) STAVLV(I,J) IHOTSTP=IHOTSTP+1 ENDDO ENDDO ENDIF IF(NHAGE.ne.0) THEN DO J=1,INP DO I=1,IMM WRITE(IHOT,REC=IHOTSTP) GLOELV(I,J) IHOTSTP=IHOTSTP+1 ENDDO ENDDO ENDIF IF(NHAGV.ne.0) THEN DO J=1,INP DO I=1,IMM WRITE(IHOT,REC=IHOTSTP) GLOULV(I,J) IHOTSTP = IHOTSTP + 1 WRITE(IHOT,REC=IHOTSTP) GLOVLV(I,J) IHOTSTP = IHOTSTP + 1 ENDDO ENDDO ENDIF ENDIF IF((FMV.GT.0.).AND.(INFREQ.GT.0).AND.(IM.EQ.0)) THEN !include means and variances IF(ITHSF.GT.ITMV) THEN WRITE(IHOT,REC=IHOTSTP) NTSTEPS IHOTSTP=IHOTSTP+1 IF(NHAGE.EQ.1) THEN DO I=1,INP WRITE(IHOT,REC=IHOTSTP) ELAV(I) IHOTSTP=IHOTSTP+1 WRITE(IHOT,REC=IHOTSTP) ELVA(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF IF(NHAGV.EQ.1) THEN DO I=1,INP WRITE(IHOT,REC=IHOTSTP) XVELAV(I) IHOTSTP=IHOTSTP+1 WRITE(IHOT,REC=IHOTSTP) YVELAV(I) IHOTSTP=IHOTSTP+1 WRITE(IHOT,REC=IHOTSTP) XVELVA(I) IHOTSTP=IHOTSTP+1 WRITE(IHOT,REC=IHOTSTP) YVELVA(I) IHOTSTP=IHOTSTP+1 ENDDO ENDIF ENDIF ENDIF ! charmv ENDIF ! HARIND #endif C C--Close Global file and all the Local Files C CLOSE (IHOT) C DEALLOCATE ( LOC2 ) nbytes = 4*nproc call memory_dealloc(nbytes) DEALLOCATE ( ETA1, ETA2, EtaDisc, UU2, VV2, NODECODE, CH1 ) nbytes = 7*mnp call memory_dealloc(nbytes) DEALLOCATE ( NOFF ) nbytes = 6*mne call memory_dealloc(nbytes) call memory_status() C RETURN 1001 FORMAT('ERROR: The hot start file') 1010 FORMAT(' File ',A60,/,' WAS NOT FOUND! ADCPrep Terminated!!!',/) 1011 FORMAT(' File ',A60,/,' WAS FOUND! Opening & Processing file',/) 1012 FORMAT('was a nonmatching version') 1005 FORMAT('exists but cannot be opened.') 9973 FORMAT(/,1X,'!!!!!! EXECUTION WILL NOW BE TERMINATED !!!!!!',//) END SUBROUTINE HOTGLOBALIZE C ---------------------------------------------------------------------- C S U B R O U T I N E R E A D H O T S T A R T 3 D C ---------------------------------------------------------------------- C C jgf46.02 This subroutine supports PREP67_68. It reads in the 3D C section of the full domain hot start file. C C ---------------------------------------------------------------------- SUBROUTINE ReadHotStart3D(UnitNumber,FilePosition) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of full domain file INTEGER, intent(inout) :: FilePosition ! position in binary file INTEGER IHOTSTP,NH,K C C Start reading in the data !kmd Added information for 3D hotstart ALLOCATE ( DUU(MNP),DUV(MNP),DVV(MNP)) ALLOCATE ( UU(MNP),VV(MNP)) ALLOCATE ( BSX(MNP),BSY(MNP)) !kmd end of additions PRINT *, "NFEN = ", NFEN IHOT=UnitNumber IHOTSTP=FilePosition PRINT *, "How many layers need to be evaluated:" READ *, NFEN PRINT *, "made it to 3D portion of code" PRINT *, "MNP = ", MNP PRINT *, "NFEN = ", NFEN PRINT *, "IHOTSTP = ", IHOTSTP !kmd Added information for 3D hotstart ALLOCATE ( WZ(MNP,NFEN), q20(MNP,NFEN)) ALLOCATE ( RealQ(MNP,NFEN), ImagQ(MNP,NFEN)) ALLOCATE ( l(MNP,NFEN), SigT(MNP,NFEN)) ALLOCATE ( Sal(MNP,NFEN), Temp(MNP,NFEN)) !kmd end of additions READ(IHOT,REC=IHOTSTP) IDEN ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DSD ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSDRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DSV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSVRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DST ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSTRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGD ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGDRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGVRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGT ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGTRec ; IHOTSTP = IHOTSTP + 1 DO NH=1,MNP READ(IHOT,REC=IHOTSTP) DUU(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) DUV(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) DVV(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) UU(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) VV(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) BSX(NH) IHOTSTP=IHOTSTP+1 END DO DO NH=1,MNP READ(IHOT,REC=IHOTSTP) BSY(NH) IHOTSTP=IHOTSTP+1 ENDDO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) RealQ(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) ImagQ(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) WZ(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) q20(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) l(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO IF (ABS(IDEN).EQ.1) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) SigT(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO END IF IF(ABS(IDen).EQ.2) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) Sal(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) Temp(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) Sal(NH,K) IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,REC=IHOTSTP) Temp(NH,K) IHOTSTP=IHOTSTP+1 ENDDO ENDDO END IF RETURN C ---------------------------------------------------------------------- END SUBROUTINE ReadHotStart3D C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C S U B R O U T I N E W R I T E H O T S T A R T 3 D C ---------------------------------------------------------------------- C C jgf46.02 This subroutine supports PREP67_68. It writes out the 3D C section of the full domain hot start file. C C ---------------------------------------------------------------------- SUBROUTINE WriteHotStart3D(UnitNumber,FilePosition,IPROC) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of subdomain file INTEGER, intent(inout) :: FilePosition ! position in binary file INTEGER IHOTSTP, LOCHSF, I, N, IINDX INTEGER, intent(in) :: IPROC C Start writing out the 3D hotstart information LOCHSF=UnitNumber IHOTSTP=FilePosition WRITE(LOCHSF,REC=IHOTSTP) IDEN ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DSD ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSDRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DSV ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSVRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DST ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSTRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGD ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGDRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGV ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGVRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGT ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGTRec ; IHOTSTP = IHOTSTP + 1 DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DUU(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DUV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DVV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) UU(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) VV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) BSX(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) BSY(IINDX) IHOTSTP=IHOTSTP+1 ENDDO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) RealQ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) ImagQ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) WZ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) q20(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) l(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO IF (ABS(IDEN).EQ.1) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) SigT(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.2) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Sal(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Temp(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Sal(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Temp(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO END IF RETURN C ---------------------------------------------------------------------- END SUBROUTINE WriteHotStart3D C ---------------------------------------------------------------------- C kmd48.33bc add in 3D global hot start files C ---------------------------------------------------------------------- C S U B R O U T I N E R E A D H O T S T A R T 3 D G L O B A L C ---------------------------------------------------------------------- C C This subroutine supports PREP67_68. It reads in the 3D C section of the full domain hot start file. C C ---------------------------------------------------------------------- SUBROUTINE ReadHotStart3DGlobal(UnitNumber,FilePosition,ProcessNo) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of full domain file INTEGER, intent(inout) :: FilePosition ! position in binary file INTEGER, intent(in) :: ProcessNo ! i/o unit of full domain file INTEGER IHOTSTP,NH,K,I,IPROC INTEGER IINDX REAL(8) RVALUE C C Start reading in the data !kmd Added information for 3D hotstart ALLOCATE ( DUU(MNP),DUV(MNP),DVV(MNP)) ALLOCATE ( UU(MNP),VV(MNP)) ALLOCATE ( BSX(MNP),BSY(MNP)) !kmd end of additions IHOT=UnitNumber IHOTSTP=FilePosition IPROC=ProcessNo PRINT*, "How many layers need to be evaluated:" READ *, NFEN C PRINT *, "Made it to the 3d portion of this" PRINT *, "NFEN = ", NFEN !kmd Added information for 3D hotstart ALLOCATE ( WZ(MNP,NFEN), q20(MNP,NFEN)) ALLOCATE ( RealQ(MNP,NFEN), ImagQ(MNP,NFEN)) ALLOCATE ( l(MNP,NFEN), SigT(MNP,NFEN)) ALLOCATE ( Sal(MNP,NFEN), Temp(MNP,NFEN)) !kmd end of additions READ(IHOT,REC=IHOTSTP) IDEN ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DSD ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSDRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DSV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSVRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DST ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DSTRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGD ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGDRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGV ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGVRec ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) N3DGT ; IHOTSTP = IHOTSTP + 1 READ(IHOT,REC=IHOTSTP) I3DGTRec ; IHOTSTP = IHOTSTP + 1 DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) DUU(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) DUV(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) DVV(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) UU(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) VV(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) BSX(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) BSY(IINDX) = RVALUE IHOTSTP=IHOTSTP+1 END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) REALQ(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) ImagQ(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) WZ(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) q20(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) l(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO IF (ABS(IDEN).EQ.1) THEN DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) SigT(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO END IF IF(ABS(IDen).EQ.2) THEN DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) Sal(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) Temp(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) Sal(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO END DO DO K=1,NFEN DO I=1,NNODP(IPROC) IINDX=IMAP_NOD_LG(I,IPROC) READ(IHOT,REC=IHOTSTP) RVALUE IF (IINDX.GT.0) TEMP(IINDX,K) = RVALUE IHOTSTP=IHOTSTP+1 END DO ENDDO END IF RETURN C ---------------------------------------------------------------------- END SUBROUTINE ReadHotStart3DGlobal C ---------------------------------------------------------------------- C kmd48.33bc added for global 3D hot start C ---------------------------------------------------------------------- C S U B R O U T I N E W R I T E H O T S T A R T 3 D G L O B A L C ---------------------------------------------------------------------- C C This subroutine supports PREP67_68. It writes out the 3D C section of the full domain hot start file. C C ---------------------------------------------------------------------- SUBROUTINE WriteHotStart3DGlobal(UnitNumber,FilePosition,IPROC) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of subdomain file INTEGER, intent(inout) :: FilePosition ! position in binary file INTEGER, intent(in) :: IPROC INTEGER IHOTSTP, LOCHSF, I, N, IINDX C Start writing out the 3D hotstart information LOCHSF=UnitNumber IHOTSTP=FilePosition WRITE(LOCHSF,REC=IHOTSTP) IDEN ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DSD ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSDRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DSV ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSVRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DST ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DSTRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGD ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGDRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGV ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGVRec ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) N3DGT ; IHOTSTP = IHOTSTP + 1 WRITE(LOCHSF,REC=IHOTSTP) I3DGTRec ; IHOTSTP = IHOTSTP + 1 DO I=1,MNP IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DUU(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DUV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) DVV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) UU(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) VV(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) BSX(IINDX) IHOTSTP=IHOTSTP+1 END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) BSY(IINDX) IHOTSTP=IHOTSTP+1 ENDDO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) RealQ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) ImagQ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) WZ(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) q20(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) l(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO IF (ABS(IDEN).EQ.1) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) SigT(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.2) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Sal(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Temp(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Sal(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,REC=IHOTSTP) Temp(IINDX,N) IHOTSTP=IHOTSTP+1 END DO END DO END IF C RETURN C ---------------------------------------------------------------------- END SUBROUTINE WriteHotStart3DGLOBAL C ---------------------------------------------------------------------- C kmd48.33bc add read information for the initial condition file C ---------------------------------------------------------------------- C S U B R O U T I N E R E A D I N I T C O N D 3 D C ---------------------------------------------------------------------- C C kmd47.22 reads in the 3D information from an initial condition C file C C ---------------------------------------------------------------------- SUBROUTINE ReadInitCond3D(UnitNumber) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of full domain file INTEGER NH,K C C Start reading in the data !kmd Added information for 3D hotstart ALLOCATE ( DUU(MNP),DUV(MNP),DVV(MNP)) ALLOCATE ( UU(MNP),VV(MNP)) ALLOCATE ( BSX(MNP),BSY(MNP)) ALLOCATE ( WZ(MNP,NFEN), q20(MNP,NFEN)) ALLOCATE ( RealQ(MNP,NFEN), ImagQ(MNP,NFEN)) ALLOCATE ( l(MNP,NFEN), SigT(MNP,NFEN)) ALLOCATE ( Sal(MNP,NFEN), Temp(MNP,NFEN)) !kmd end of additions IHOT=UnitNumber READ(IHOT,*) IDEN DO NH=1,MNP READ(IHOT,*) BSX(NH) END DO DO NH=1,MNP READ(IHOT,*) BSY(NH) END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) RealQ(NH,K) END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) ImagQ(NH,K) END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) WZ(NH,K) END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) q20(NH,K) END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) l(NH,K) END DO END DO IF (ABS(IDEN).EQ.1) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) SigT(NH,K) END DO END DO END IF IF(ABS(IDen).EQ.2) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) Sal(NH,K) END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) Temp(NH,K) END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) Sal(NH,K) END DO END DO DO K=1,NFEN DO NH=1,MNP READ(IHOT,*) Temp(NH,K) ENDDO ENDDO END IF RETURN C ---------------------------------------------------------------------- END SUBROUTINE ReadInitCond3D C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C S U B R O U T I N E W R I T E I N I T C O N D 3 D C ---------------------------------------------------------------------- C C kmd47.22 This subroutine writes out the 3D section of the C full domain initial condtion file. C C ---------------------------------------------------------------------- SUBROUTINE WriteInitCond3D(UnitNumber,IPROC) C ---------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit of subdomain file INTEGER LOCHSF, I, N, IINDX INTEGER, intent(in) :: IPROC C Start writing out the 3D initial condition information LOCHSF=UnitNumber WRITE(LOCHSF,*) IDEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) BSX(IINDX) END DO DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) BSY(IINDX) END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) RealQ(IINDX,N) END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) ImagQ(IINDX,N) END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) WZ(IINDX,N) END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) q20(IINDX,N) END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) l(IINDX,N) END DO END DO IF (ABS(IDEN).EQ.1) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) SigT(IINDX,N) END DO END DO ENDIF IF(ABS(IDen).EQ.2) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) Sal(IINDX,N) END DO END DO ENDIF IF(ABS(IDen).EQ.3) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) Temp(IINDX,N) END DO END DO ENDIF IF(ABS(IDen).EQ.4) THEN DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) Sal(IINDX,N) END DO END DO DO N=1,NFEN DO I=1,NNODP(IPROC) IINDX=ABS(IMAP_NOD_LG(I,IPROC)) WRITE(LOCHSF,*) Temp(IINDX,N) END DO END DO END IF C RETURN C ---------------------------------------------------------------------- END SUBROUTINE WriteInitCond3D C ---------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E O P E N F U L L D O M A I N F I L E C--------------------------------------------------------------------------- C C jgf47.02 This subroutine will open the full domain file C C--------------------------------------------------------------------------- SUBROUTINE OpenFullDomainFile(UnitNumber, Description, Success) C--------------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit number to open CHARACTER(len=30), intent(in) :: Description ! description of file LOGICAL, intent(out):: Success ! .true. if file opened w/o errors LOGICAL Found !.true. if the full domain file exists CHARACTER(len=80) FileName ! name of full domain file CHARACTER(len=7) DefaultName! default name of full domain file INTEGER ErrorIO ! zero if file opened successfully CHARACTER(len=4) skipstring ! indicates user wants to skip this file Found = .false. Success = .false. ErrorIO = 1 skipstring = 'skip' DefaultName(1:5) = 'fort.' WRITE(DefaultName(6:7),2) UnitNumber C C Determine the name of the file; if found, open it 31 IF (USE_DEFAULT) THEN FileName = DefaultName ELSE WRITE(*,850) ! type skip to bypass WRITE(*,900) Description WRITE(*,910) UnitNumber READ(*,'(A)') FileName FileName = trim(FILENAME) ENDIF C C Determine if full domain file exists INQUIRE(FILE=FileName,EXIST=FOUND) C C If it does exist, open it IF ( FOUND ) THEN WRITE(*,1011) trim(FileName) !found OPEN(UNIT=UnitNumber, FILE=FileName, IOSTAT=ErrorIO) Success = .true. IF ( ErrorIO .GT. 0 ) THEN WRITE(*,*) "ERROR: Full domain file exists but" WRITE(*,*) "cannot be opened." Success = .false. ELSE WRITE(*,*) "Successfully opened full domain file." ENDIF ELSE C Give the user a chance to opt out of prepping this file. IF (FileName .eq. skipstring) RETURN ! note the early RETURN WRITE(*,1010) trim(FileName) !not found GOTO 31 ENDIF 2 FORMAT(I2) 30 FORMAT(A30) 850 FORMAT(/,'Type ''skip'' to bypass preprocessing or') 900 FORMAT('Enter the name of the ',A30) 910 FORMAT('file (unit ',I3,'): ') 1010 FORMAT('WARNING: File ',A,' WAS NOT FOUND! Try again or type "skip"',/) 1011 FORMAT('INFO: File ',A,' WAS FOUND! Opening & Processing file.',/) RETURN C--------------------------------------------------------------------------- END SUBROUTINE OpenFullDomainFile C--------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E O P E N S U B D O M A I N F I L E C--------------------------------------------------------------------------- C C jgf47.02 This subroutine will open a single subdomain file C C--------------------------------------------------------------------------- SUBROUTINE OpenSubDomainFile(UnitNumber, IProc, sdu, Success) C--------------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit number of full dom file INTEGER, intent(in) :: iproc ! subdomain number INTEGER, intent(out) :: sdu ! i/o unit nunber that was opened LOGICAL, intent(out):: Success ! .true. if files opened w/o errors LOGICAL Found !.true. if the full domain file exists CHARACTER(len=80) FileName ! name of full domain file CHARACTER(len=7) DefaultName! default name of full domain file INTEGER ErrorIO ! zero if file opened successfully CHARACTER*14 sdFileName ! subdomain file name CHARACTER(len=4) skipstring ! indicates user wants to skip this file Found = .false. Success = .false. ErrorIO = 1 skipstring = 'skip' DefaultName(1:5) = 'fort.' WRITE(DefaultName(6:7),2) UnitNumber C Open subdomain file sdu = 105 + (iproc-1) sdFileName(1:7) = 'PE0000/' sdFileName(8:14) = DefaultName CALL IWRITE(sdFileName, 3, 6, iproc-1) OPEN (UNIT=sdu, FILE=sdFileName, IOSTAT=ErrorIO) Success = .true. IF ( ErrorIO .GT. 0 ) THEN WRITE(*,*) "ERROR: Subdomain file cannot be opened." print *,sdu print *,sdFileName Success = .false. ENDIF 2 FORMAT(I2) RETURN C--------------------------------------------------------------------------- END SUBROUTINE OpenSubDomainFile C--------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E O P E N P R E P F I L E S C--------------------------------------------------------------------------- C C jgf45.12 This subroutine will open the full domain file and each C of the subdomain files in the range of subdomains provided in the C arguments. It assumes that all unit numbers are between 10 and 99. C C tcm v50.66.03 -- incrased unit numbers to include 10 - 999. C--------------------------------------------------------------------------- SUBROUTINE OpenPrepFiles(UnitNumber, Description, & startProc, endProc, SDU, Success) C--------------------------------------------------------------------------- USE PRE_GLOBAL IMPLICIT NONE INTEGER, intent(in) :: UnitNumber ! i/o unit number to open CHARACTER(*), intent(in) :: Description ! description of file INTEGER, intent(in) :: startProc ! subdomains to start with INTEGER, intent(in) :: endProc ! subdomain to end on INTEGER, intent(out), dimension(nproc) :: SDU ! Subdomain unit numbers LOGICAL, intent(out):: Success ! .true. if files opened w/o errors LOGICAL Found !.true. if the full domain file exists CHARACTER(len=80) FileName ! name of full domain file CHARACTER(len=80) DefaultName! default name of full domain file INTEGER :: dnlen !length of defaultname (7 or 8) INTEGER ErrorIO ! zero if file opened successfully INTEGER iproc ! subdomain index CHARACTER(len=20) sdFileName ! subdomain file name !increased from 14 to 15 tcm v50.66.03 CHARACTER(len=4) skipstring ! indicates user wants to skip this file INTEGER:: unitwidth CHARACTER (len=20):: unitnumberstr Found = .false. Success = .false. ErrorIO = 1 skipstring = 'skip' DefaultName(:) = ' ' !initialize to all blanks !tcm v50.77 DefaultName(1:5) = 'fort.' unitwidth = ceiling(log(dble(UnitNumber))/log(10.0)) ; dnlen = 5 + unitwidth ; WRITE(unitnumberstr,'(I0)') UnitNumber ; DefaultName = TRIM(ADJUSTL(DefaultName))//TRIM(ADJUSTL(unitNumberStr)) C C Determine the name of the file; if found, open it 31 IF (USE_DEFAULT) THEN FileName = trim(DefaultName(1:dnlen)) !tcm v50.66.03 added trim !tcm v50.77 added 1:dnlen Casey 120402: Avoid an endless loop. If the default file does not exist, C then give the user a chance to specify the file name or skip.a C ELSE GOTO 33 ENDIF 32 CONTINUE WRITE(*,850) ! type skip to bypass WRITE(*,900) Description WRITE(*,910) UnitNumber READ(*,'(A)') FileName FileName = trim(FILENAME) C ENDIF 33 CONTINUE C C Determine if full domain file exists INQUIRE(FILE=FileName,EXIST=FOUND) C C If it does exist, open it IF ( FOUND ) THEN WRITE(*,1011) FileName !found OPEN(UNIT=UnitNumber, FILE=FileName, IOSTAT=ErrorIO) Success = .true. IF ( ErrorIO .GT. 0 ) THEN WRITE(*,*) "ERROR: Full domain file exists but" WRITE(*,*) "cannot be opened." Success = .false. ENDIF ELSE C Give the user a chance to opt out of prepping this file. IF (FileName .eq. skipstring) RETURN ! note the early RETURN WRITE(*,1010) FileName !not found Casey 120402: Avoid an endless loop. If the default file does not exist, C then give the user a chance to specify the file name or skip. C GOTO 31 GOTO 32 ENDIF C If (.not.Success) RETURN ! failed to open full domain file C C Open each of the subdomain files DO iproc = startProc, endProc sdFileName(:) = ' ' sdu(iproc) = 505 + (iproc-1) !tcm v51.31 changed 105 to 505 to avoid conflicts with fort.141 file sdFileName(1:7) = 'PE0000/' c........tcm v50.66.03 increased unit number to 100's places sdFileName(8:) = trim(DefaultName) #ifdef ADCSWAN sdFileName = 'PE0000/'//FileName #endif CALL IWRITE(sdFileName, 3, 6, iproc-1) OPEN (UNIT=SDU(iproc), FILE=trim(sdFileName), IOSTAT=ErrorIO) Success = .true. IF ( ErrorIO .GT. 0 ) THEN WRITE(*,*) "ERROR: Subdomain file cannot be opened." Success = .false. RETURN ! failed to open at least one subdomain file ENDIF ENDDO 2 FORMAT(I2) 3 FORMAT(I3) 30 FORMAT(A30) 850 FORMAT(/,'Type ''skip'' to bypass preprocessing or') 900 FORMAT('Enter the name of the ',A30) 910 FORMAT('file (unit ',I3,'): ') 1010 FORMAT('File ',A8,/,' WAS NOT FOUND! Try again or type "skip"',/) !increased A7 to A8 tcm v50.66.03 1011 FORMAT('File ',A8,/,' WAS FOUND! Opening & Processing file.',/) !increased A7 to A8 RETURN C--------------------------------------------------------------------------- END SUBROUTINE OpenPrepFiles C--------------------------------------------------------------------------- c*********************************************************************** c Subroutine to write out to the hotstart file (UNITS 67 and 68) * c header information and the LHS matrix for the harmonic analysis * c * c R.L. 11/8/95 * c*********************************************************************** c c SUBROUTINE HAHOUT(NP,NSTAE,NSTAV,ISTAE,ISTAV,IGLOE,IGLOV, c & IOUNIT,IHOTSTP) c implicit none c INTEGER NP,NSTAE,NSTAV,ISTAE,AE,ISTAV c INTEGER IGLOE,IGLOV,IOUNIT,IHOTSTP,I,J c CHARACTER*16 FNAME c CHARACTER*8 FNAM8(2) c EQUIVALENCE (FNAM8(1),FNAME)c c c c***** Write Out various parameter values c c WRITE(IOUNIT,REC=IHOTSTP+1) NZ c WRITE(IOUNIT,REC=IHOTSTP+2) NF c WRITE(IOUNIT,REC=IHOTSTP+3) MM c WRITE(IOUNIT,REC=IHOTSTP+4) NP c WRITE(IOUNIT,REC=IHOTSTP+5) NSTAE c WRITE(IOUNIT,REC=IHOTSTP+6) NSTAV c WRITE(IOUNIT,REC=IHOTSTP+7) ISTAE c WRITE(IOUNIT,REC=IHOTSTP+8) ISTAV c WRITE(IOUNIT,REC=IHOTSTP+9) IGLOE c WRITE(IOUNIT,REC=IHOTSTP+10) IGLOV c WRITE(IOUNIT,REC=IHOTSTP+11) ICALL c WRITE(IOUNIT,REC=IHOTSTP+12) NFREQ c IHOTSTP = IHOTSTP+12 c c do i=1,nfreq+nf c FNAME=NAMEFR(I) c WRITE(IOUNIT,REC=IHOTSTP+1) FNAM8(1) c WRITE(IOUNIT,REC=IHOTSTP+2) FNAM8(2) c IHOTSTP=IHOTSTP+2 c WRITE(IOUNIT,REC=IHOTSTP+1) hafreq(i) c WRITE(IOUNIT,REC=IHOTSTP+2) HAFF(i) c WRITE(IOUNIT,REC=IHOTSTP+3) HAFACE(i) c IHOTSTP=IHOTSTP+3 c end do c c c***** Write Out time of most recent H.A. update c c WRITE(IOUNIT,REC=IHOTSTP+1) TIMEUD c WRITE(IOUNIT,REC=IHOTSTP+2) ITUD c IHOTSTP=IHOTSTP+2 c c***** Write Out LHS Matrix c c do i=1,mm c do j=1,mm c IHOTSTP = IHOTSTP + 1 c WRITE(IOUNIT,REC=IHOTSTP) HA(I,J) c END DO c END DO c c return c end subroutine c c*********************************************************************** c Subroutine to write global elevation harmonic analysis RHS load * c vector to a hot start file (UNITS 67 and 68) * c * c R.L. 11/8/95 * c*********************************************************************** c c SUBROUTINE HAHOUTEG(NP,IOUNIT,IHOTSTP) c implicit none c INTEGER IOUNIT c INTEGER NP,IHOTSTP,N,I c c***** Write Out Global Elevation RHS load vector c c do n=1,np c do i=1,mm c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) GLOELV(I,N) c end do c end do c c return c end subroutine c*********************************************************************** c Subroutine to write elevation station harmonic analysis RHS load * c vector to a hot start file (UNITS 67 and 68) * c * c R.L. 11/8/95 * c*********************************************************************** c c SUBROUTINE HAHOUTES(NSTAE,IOUNIT,IHOTSTP) c implicit none c INTEGER NSTAE,IOUNIT,IHOTSTP,N,I c c***** Write Out Station Elevation RHS load vector c c do n=1,NSTAE c do i=1,mm c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) STAELV(I,N) c end do c end do c c return c end subroutine c c*********************************************************************** c Subroutine to write global velocity harmonic analysis RHS load * c vector to a hot start file (UNITS 67 and 68) * c * c R.L. 11/8/95 * c*********************************************************************** c c SUBROUTINE HAHOUTVG(NP,IOUNIT,IHOTSTP) c implicit none c INTEGER NP,IOUNIT,IHOTSTP,N,I c c***** Write Out Global Velocity RHS load vector c c do n=1,np c do i=1,mm c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) GLOULV(I,N) c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) GLOVLV(I,N) c end do c end do c c return c end subroutine c c*********************************************************************** c Subroutine to write velocity station harmonic analysis RHS load * c vector to a hot start file (UNITS 67 and 68) * c * c R.L. 11/8/95 * c*********************************************************************** c c SUBROUTINE HAHOUTVS(NSTAV,IOUNIT,IHOTSTP) c implicit none c INTEGER NSTAV,IOUNIT,IHOTSTP,N,I c c***** Write Out Station Velocity LHS load vector c c do N=1,NSTAV c do i=1,mm c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) STAULV(I,N) c IHOTSTP=IHOTSTP+1 c WRITE(IOUNIT,REC=IHOTSTP) STAVLV(I,N) c end do c end do c c return c end subroutine C C---------------------------------------------------------------------------C C ( Serial Version 2/28/98 ) C C This routine writes the domain decomposition information into a file, C C "fort.80". This file is used by the ADCIRC post-processor ADCPOST. C C This version is compatible with ADCIRC version 34.03 C C C C jgf45.07 Added subdomain->fulldomain element mapping to handle the C C processing of the NOFF array. C jgf45.11 Added IDEN for processing fort.44 file, added additional C arrays to handle processing of 3D recording stations. C---------------------------------------------------------------------------C CC Addition by CF 8/2007 SUBROUTINE PREP80() USE PRE_GLOBAL USE SIZES, ONLY : MNHARF USE HARM, ONLY : NHASE, NHASV, NHAGE, NHAGV IMPLICIT NONE INTEGER I,K C OPEN(UNIT=80,FILE='fort.80') ! output for ADCPOST C C--Write out the domain decomposition information into a file C which will later be used in post-processing the results C WRITE(80,80) RUNDES WRITE(80,80) RUNID WRITE(80,80) AGRID WRITE(80,'(2I8,16x,A)') NELG,NNODG,'! Total # elements & nodes' WRITE(80,'(I8,24x,A)') NPROC,' ! Number of processors' WRITE(80,'(I8,24x,A)') MNPP,'! Max nodes on any processor' WRITE(80,'(I8,24x,A)') MNEP,'! Max elements on any processor'!jgf45.07 WRITE(80,'(I8,24x,A)') IM,'! IM, run type' !jgf46.02 WRITE(80,'(I8,24x,A)') NWS,'! NWS, wind data type' !jgf46.02 WRITE(80,'(I8,24x,A)') abs(NSTAE),'! NSTAE' WRITE(80,'(I8,24x,A)') abs(NSTAV),'! NSTAV' IF (IM.EQ.10) THEN WRITE(80,'(I8,24x,A)') abs(NSTAC),' ! NSTAC' !jgf46.02 ENDIF IF (NWS.NE.0) THEN WRITE(80,'(I8,24x,A)') abs(NSTAM),'! NSTAM' !jgf46.02 ENDIF WRITE(80,'(I8,24x,A)') MNHARF,'! MNHARF' WRITE(80,'(2I8,16x,A)') MNWLAT,MNWLON,'! NWLON, NWLAT' C Casey 100301: Changed I8 to I12. DO I = 1,NPROC WRITE(80,'(3I8,A33)') I-1, NNODP(I), NOD_RES_TOT(I), & ' ! PE, NNODP(PE), NOD_RES_TOT(PE)' WRITE(80,'(9I12)') (IMAP_NOD_LG(K,I),K=1,NNODP(I)) ENDDO C WRITE(80,*) "GLOBAL PE LOCAL ( Global-to-Local Nodes )" DO I = 1,NNODG WRITE(80,1140) I, IMAP_NOD_GL(1,I)-1, IMAP_NOD_GL(2,I) ENDDO C C jgf45.07 Add subdomain->fulldomain mapping to handle NOFF processing C IMAP_EL_LG(I,PE) = Global Element Number of Local Element I on PE Casey 100301: Changed I8 to I12. DO I = 1,NPROC WRITE(80,'(2I8,A33)') I-1, NELP(I), ' ! PE, NELP(PE)' WRITE(80,'(9I12)') (IMAP_EL_LG(K,I),K=1,NELP(I)) ENDDO C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTE,TOUTSE,TOUTFE,NSPOOLE, & ' ! NOUTE,TOUTSE,TOUTFE,NSPOOLE' C DO I = 1,NPROC WRITE(80,*) I,NSTAEP(I) DO K = 1,NSTAEP(I) WRITE(80,*) IMAP_STAE_LG(K,I) ENDDO ENDDO C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTV,TOUTSV,TOUTFV,NSPOOLV, & ' ! NOUTV,TOUTSV,TOUTFV,NSPOOLV' C DO I = 1,NPROC WRITE(80,*) I,NSTAVP(I) DO K = 1,NSTAVP(I) WRITE(80,*) IMAP_STAV_LG(K,I) ENDDO ENDDO C IF (IM.EQ.10) THEN ! jgf46.02 WRITE(80,'(I8,2E15.8,I8,A32)') NOUTC,TOUTSC,TOUTFC,NSPOOLC, & ' ! NOUTC,TOUTSC,TOUTFC,NSPOOLC' DO I = 1,NPROC WRITE(80,*) I,NSTACP(I) DO K = 1,NSTACP(I) WRITE(80,*) IMAP_STAC_LG(K,I) ENDDO ENDDO ENDIF C IF (NWS.NE.0) THEN ! jgf46.02 WRITE(80,'(I8,2E15.8,I8,A32)') NOUTM,TOUTSM,TOUTFM,NSPOOLM, & ' ! NOUTM,TOUTSM,TOUTFM,NSPOOLM' DO I = 1,NPROC WRITE(80,*) I,NSTAMP(I) DO K = 1,NSTAMP(I) WRITE(80,*) IMAP_STAM_LG(K,I) ENDDO ENDDO ENDIF C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTGE, TOUTSGE,TOUTFGE,NSPOOLGE, & ' ! NOUTGE, TOUTSGE, TOUTFGE, NSPOOLGE' C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTGV, TOUTSGV,TOUTFGV,NSPOOLGV, & ' ! NOUTGV, TOUTSGV, TOUTFGV, NSPOOLGV' C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTGC, TOUTSGC,TOUTFGC,NSPOOLGC, & ' ! NOUTGC, TOUTSGC, TOUTFGC, NSPOOLGC' C WRITE(80,'(I8,2E15.8,I8,A32)') NOUTGW, TOUTSGW,TOUTFGW,NSPOOLGW, & ' ! NOUTGW, TOUTSGW, TOUTFGW, NSPOOLGW' C WRITE(80,'(4I4,A32)') NHASE,NHASV,NHAGE,NHAGV, & ' ! NHASE, NHASV, NHAGE, NHAGV' C ------------------------------------------------------------- C C S T A R T 3 D D A T A C C ------------------------------------------------------------- WRITE(80,*) IDEN !jgf45.11 needed to post process the fort.44 file C ------------------------------------------------------------- C jgf45.11 Write mappings for 3D density stations. C ------------------------------------------------------------- WRITE(80,81) I3DSD, TO3DSDS, TO3DSDF, NSPO3DSD, NSTA3DD, & ' ! I3DSD, TO3DSDS, TO3DSDF, NSPO3DSD, NSTA3DD' IF(I3DSD.NE.0) THEN DO I = 1, NPROC WRITE(80,*) I, NNSTA3DDP(I) DO K = 1, NNSTA3DDP(I) WRITE(80,*) IMAP_STA3DD_LG(K,I) ENDDO ENDDO ENDIF C ------------------------------------------------------------- C jgf45.11 Write mappings for 3D velocity stations. C ------------------------------------------------------------- WRITE(80,81) I3DSV, TO3DSVS, TO3DSVF, NSPO3DSV, NSTA3DV, & ' ! I3DSV, TO3DSVS, TO3DSVF, NSPO3DSV, NSTA3DV' IF(I3DSV.NE.0) THEN DO I = 1, NPROC WRITE(80,*) I, NNSTA3DVP(I) DO K = 1, NNSTA3DVP(I) WRITE(80,*) IMAP_STA3DV_LG(K,I) ENDDO ENDDO ENDIF C ------------------------------------------------------------- C jgf45.11 Write mappings for 3D turbulence stations. C ------------------------------------------------------------- WRITE(80,81) I3DST, TO3DSTS, TO3DSTF, NSPO3DST, NSTA3DT, & ' ! I3DST, TO3DSST, TO3DFST, NSPO3DST, NSTA3DT' IF(I3DST.NE.0) THEN DO I = 1, NPROC WRITE(80,*) I, NNSTA3DTP(I) DO K = 1, NNSTA3DTP(I) WRITE(80,*) IMAP_STA3DT_LG(K,I) ENDDO ENDDO ENDIF WRITE(80,82) I3DGD, TO3DGDS, TO3DGDF, NSPO3DGD, & ' ! I3DGD, TO3DGDS, TO3DGDF, NSPO3DGD' WRITE(80,82) I3DGV, TO3DGVS, TO3DGVF, NSPO3DGV, & ' ! I3DGV, TO3DGVS, TO3DGVF, NSPO3DGV' WRITE(80,82) I3DGT, TO3DGTS, TO3DGTF, NSPO3DGT, & ' ! I3DGT, TO3DGTS, TO3DGTF, NSPO3DGT' C C End 3D data C WRITE(80,*) NBYTE C CLOSE(80) C 80 FORMAT(A80) 81 FORMAT(I8,2E15.8,2I8,A32) 82 FORMAT(I8,2E15.8,I8,A32) 1130 FORMAT(8X,9I8) 1140 FORMAT(8X,3I8) C RETURN END C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P U N S W A N C--------------------------------------------------------------------------- C C jgf48.17 This subroutine just copies the UnSWAN input file to each C subdomain. Currently, it is only called if the compiler directive C ADCSWAN is defined. C C jgf50.15: After discussion with Casey, it was decided that changes C should be made such that adcprep looks for the swaninit file and C parses it to find the name of the swan control file (conventionally C called fort.26 in the adcirc community). It should then attempt to C copy that file to the subdomains. C--------------------------------------------------------------------------- SUBROUTINE prepUnSWAN C--------------------------------------------------------------------------- USE PRE_GLOBAL use memory_usage IMPLICIT NONE INTEGER I,J,IPROC,IPROC2,ILNODE,INDX,NHG,LINDEX CHARACTER*170 Line ! line of data from UnSWAN file INTEGER SDU(NPROC) ! subdomain unit numbers LOGICAL Success ! .true. if all files open without error LOGICAL swanInitFound !.true. if the swaninit file was found LOGICAL origUseDefault ! there is no default UnSWAN input file name INTEGER swiLUN ! logical unit number of swaninit file INTEGER ErrorIO ! zero if the file was opened successfully LOGICAL readError ! .true. if there was an error reading a file CHARACTER(36) swanComFile ! name of swan command file LOGICAL swanComFound ! .true. if swan command file was found CHARACTER(len=43) sdFileName ! subdomain file name C C Casey 110627: Set the unit number. swiLUN = 26 Casey 120402: Changes through this section. The procedure here is: C 1. Check for the swaninit file. If it exists, then read the name C of the SWAN control file from the fourth line of swaninit. C 2. If the swaninit file does not exist, then the user may be using C the default control file of INPUT. Check for the INPUT file. C If it exists, then use it as the SWAN control file. C 3. Otherwise, notify the user of the error. swanInitFound = .false. swanComFound = .false. readError = .true. INQUIRE(FILE='swaninit',EXIST=swanInitFound) IF (swanInitFound.eqv..true.) THEN WRITE(*,*) "INFO: The swaninit file was found." OPEN(swiLUN,FILE='swaninit',ACTION='READ', & ACCESS='SEQUENTIAL',IOSTAT=ErrorIO,STATUS='OLD') IF (ErrorIO.ne.0) THEN WRITE(*,*) "ERROR: The swaninit file could not be opened." ELSE WRITE(*,*) & "INFO: Parsing swaninit file for swan command file name." ! skip down to the 4th line DO I=1,4 READ(swiLUN,*,ERR=4321,END=4321,IOSTAT=ErrorIO) Line ENDDO READ(Line,*,ERR=4321,END=4321,IOSTAT=ErrorIO) swanComFile Casey 110627: Close the swaninit file. CLOSE(UNIT=swiLUN,STATUS='KEEP') WRITE(*,*) "INFO: The swan command file is '", & trim(swanComFile),"'." readError = .false. Casey 120402: Changes to handle the default INPUT control file. ! If swan was started without a swaninit file, it will create ! its own swaninit, and it will use the string INPUT to ! represent the name of the swan command file. C IF (TRIM(swanComFile).eq.'INPUT') THEN C WRITE(*,*) "ERROR: 'INPUT' is an invalid name." C ELSE ! check to see if the swan command file is present INQUIRE(FILE=trim(swanComFile),EXIST=swanComFound) IF (swanComFound.eqv..true.) THEN WRITE(*,*) "INFO: The swan command file '", & trim(swanComFile),"' was found." OPEN(26,FILE=trim(swanComFile),ACTION='READ', & ACCESS='SEQUENTIAL',IOSTAT=ErrorIO,STATUS='OLD') IF (ErrorIO.ne.0) THEN WRITE(*,*) "ERROR: The swan command file '", & trim(swanComFile),"' could not be opened." ENDIF ELSE WRITE(*,*) "ERROR: The swan command file '", & trim(swanComFile),"' was not found." ENDIF C ENDIF ENDIF Casey 120402: Changes to handle the default INPUT control file. ELSE INQUIRE(FILE='INPUT',EXIST=swanComFound) IF(swanComFound.eqv..true.)THEN WRITE(swanComFile,'(A)') "INPUT" readError = .false. ErrorIO = 0 swanInitFound = .true. swanComFound = .true. WRITE(*,*) "INFO: The swan command file is '", & trim(swanComFile),"'." ! Casey 120402: Changes to handle the default INPUT control file. OPEN(UNIT=26,FILE=TRIM(swanComFile),ACTION='READ') ENDIF ENDIF 4321 IF ((readError.eqv..true.).or.(ErrorIO.ne.0).or. & (swanInitFound.eqv..false.).or. & (swanComFound.eqv..false.)) THEN WRITE(*,*) 'ERROR: There was an error reading swan files.' WRITE(*,*) 'WARNING: swan files not preprocessed.' RETURN ! note early return ENDIF C C Open each of the subdomain files DO iproc = 1, nproc sdu(iproc) = 105 + (iproc-1) sdFileName = 'PE0000/'//swanComFile CALL IWRITE(sdFileName, 3, 6, iproc-1) OPEN (UNIT=SDU(iproc), FILE=TRIM(sdFileName), IOSTAT=ErrorIO) IF ( ErrorIO .GT. 0 ) THEN WRITE(*,*) "ERROR: Subdomain file '",TRIM(sdFileName), & " cannot be opened." RETURN ! failed to open at least one subdomain file ENDIF ENDDO C Casey 090304: Changed the formatting through the next section. DO READ(26,'(A)',END=9999) Line DO IPROC = 1,NPROC WRITE(SDU(IPROC),'(A)') trim(Line) ENDDO ENDDO C C--Close fulldomain file and all the subdomain files C 9999 CLOSE (26) DO IPROC=1, NPROC CLOSE (SDU(IPROC)) ENDDO RETURN 60 FORMAT(A60) 170 FORMAT(A170) 1100 FORMAT(I8,3E13.5) 1101 FORMAT(' #') c---------------------------------------------------------------------------- END SUBROUTINE prepUnSWAN c---------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E P R E P N E T C D F C--------------------------------------------------------------------------- C C jgf49.31 This subroutine will initialize the fulldomain netcdf C output files for the parallel run. These files are initialized C in the adcprep phase because they contain fulldomain data which C are not available to the subdomains during a parallel run. C C--------------------------------------------------------------------------- SUBROUTINE prepNetCDF() #ifdef ADCNETCDF use sizes, only : ASCII, XDMF, myproc USE PRESIZES, ONLY: NM, MNTIF, MNE, MNP USE HARM, ONLY : IHARIND, CHARMV, NHASE, NHASV, NHAGE, NHAGV USE VERSION USE PRE_GLOBAL, ONLY: NSTAE, NOUTE, RUNDES, RUNID, AGRID, & DTDP, TAU0, STATIM, REFTIM, RNDAY, DRAMP, A00, B00, C00, & H0, SL0, SF0, CF, ESLM, CORI, DP, NBDV, NBVV, & SLEL, SFEL, ICS, NT, NTRSPE, IHOT, NOLIBF, NOLIFA, IM, & XEV,YEV,XEM,YEM,XEL,YEL,X,Y,NELG,DT, NTIF, NODECODE, & NOLICA, NOLICAT, NWP, NCOR, NTIP, NWS, NRS, NRAMP, NBFR, & NHARFR, NHY, NOPE, NETA, NBOU, NVEL, G, SL1, SF1, & NVDLL, NVELL, IBTYPE, IBTYPEE, & NSTAV, NOUTV, SLEV, SFEV, NTRSPV, & NSTAM, NOUTM, SLEM, SFEM, NTRSPM, & NOUTGE, SLAM, SFEA, NDSETSE, & NOUTGV, NDSETSV, & NOUTGW, NDSETSW, & IESTP,NSCOUE,IVSTP,NSCOUV,ICSTP,NSCOUC,IPSTP,IWSTP,NSCOUM, & IGEP,NSCOUGE,IGVP,NSCOUGV,IGCP,NSCOUGC,IGPP,IGWP,NSCOUGW, & nhstar,nhsinc, & title, institution, & source, history, references, comments, host, convention, & contact, base_date, NABOUT, NSCREEN, inundationOutput, & I3DSD, NFEN, NSTA3DD, I3DSV, NSTA3DV, I3DST, NSTA3DT, & I3DGD, I3DGV, I3DGT, IDEN, islip, kp, z0s, z0b, theta1, & theta2, ievc, evmin, evcon, alp1, alp2, alp3, igc, nlsd, & nvsd, nltd, nvtd, alp4, C3D, X3DD, Y3DD, SL3DD, SF3DD, & X3DV, Y3DV, SL3DV, SF3DV, X3DT, Y3DT, SL3DT, SF3DT, C3D, & foundCorrectionControlNamelist USE NODALATTRIBUTES, ONLY : outputTau0 USE NETCDFIO, ONLY : setADCIRCParameters, initNetCDFOutputFile, & initNetCDFHotstart3D, initNetCDFHotstart, & initNetCDFHotstartHarmonic, & initNetCDFHotstartHarmonicMeansVariances, & freeNetCDFCoord #ifdef ADCSWAN USE GLOBAL, ONLY : OutputDataDescript_t, screenUnit, & SWAN_OutputHS,SWAN_OutputDIR,SWAN_OutputTM01, & SWAN_OutputTPS,SWAN_OutputWIND,SWAN_OutputTM02, & SWAN_OutputTMM10,NOUT_TVW,outputWindDrag #else USE GLOBAL, ONLY : OutputDataDescript_t, screenUnit, & NOUT_TVW,outputWindDrag #endif C IMPLICIT NONE LOGICAL reterr C C The initialization of the output data descriptors for each ADCIRC C output file had to be cut and pasted from write_output.F. At some C point in the future, adcprep will be part of adcirc, making this C unfortunate cut-and-paste duplication unnecessary. !WJP 02.20.2018 Adding capability for fort.51-54 type(OutputDataDescript_t), SAVE :: HaElevStaDescript ! fort.51 type(OutputDataDescript_t), SAVE :: HaVelStaDescript ! fort.52 type(OutputDataDescript_t), SAVE :: HaElevDescript ! fort.53 type(OutputDataDescript_t), SAVE :: HaVelDescript ! fort.54 type(OutputDataDescript_t), SAVE :: ElevStaDescript ! fort.61 type(OutputDataDescript_t), SAVE :: VelStaDescript ! fort.62 type(OutputDataDescript_t), SAVE :: ElevDescript ! fort.63 type(OutputDataDescript_t), SAVE :: Tau0Descript ! fort.90 type(OutputDataDescript_t), SAVE :: VelDescript ! fort.64 type(OutputDataDescript_t), SAVE :: PrStaDescript ! fort.71 type(OutputDataDescript_t), SAVE :: WindVelStaDescript ! fort.72 type(OutputDataDescript_t), SAVE :: PrDescript ! fort.73 type(OutputDataDescript_t), SAVE :: windDragDescript ! winddrag.173 type(OutputDataDescript_t), SAVE :: WindVelDescript ! fort.74 type(OutputDataDescript_t), SAVE :: weirElevDescript ! fort.77 type(OutputDataDescript_t), SAVE :: EtaMaxDescript ! maxele.63 type(OutputDataDescript_t), SAVE :: UMaxDescript ! maxvel.63 type(OutputDataDescript_t), SAVE :: PrMinDescript ! minpr.63 type(OutputDataDescript_t), SAVE :: WVMaxDescript ! maxwvel.63 type(OutputDataDescript_t), SAVE :: RSMaxDescript type(OutputDataDescript_t), SAVE :: InundationTimeDescript ! inundationtime.63 type(OutputDataDescript_t), SAVE :: MaxInunDepthDescript ! maxinundepth.63 type(OutputDataDescript_t), SAVE :: InitiallyDryDescript ! initiallydry.63 type(OutputDataDescript_t), SAVE :: EndRisingInunDescript ! endrisinginun.63 type(OutputDataDescript_t), SAVE :: EverDriedDescript ! everdried.63 type(OutputDataDescript_t), SAVE :: dynamicWaterlevelCorrectionDescript ! dynamicWaterlevelCorrection.63 type(OutputDataDescript_t), SAVE :: dynamicWaterlevelCorrectionStaDescript ! dynamicWaterlevelCorrection.61 ! tcm v50.75 moved RSDescript outside of the ifdef adcswan for use with ! nrs = 3 or nrs= 4 or nrs = 5 type(OutputDataDescript_t), SAVE :: RSDescript #ifdef ADCSWAN Cobell 20120510: SWAN Output Data type(OutputDataDescript_t), SAVE :: SwanHSDescript type(OutputDataDescript_t), SAVE :: SwanDIRDescript type(OutputDataDescript_t), SAVE :: SwanTM01Descript type(OutputDataDescript_t), SAVE :: SwanTPSDescript type(OutputDataDescript_t), SAVE :: SwanWindDescript type(OutputDataDescript_t), SAVE :: SwanTM02Descript type(OutputDataDescript_t), SAVE :: SwanTMM10Descript ! type(OutputDataDescript_t), SAVE :: RSDescript ! tcm v50.75 moved type(OutputDataDescript_t), SAVE :: SwanHSMaxDescript type(OutputDataDescript_t), SAVE :: SwanDIRMaxDescript type(OutputDataDescript_t), SAVE :: SwanTM01MaxDescript type(OutputDataDescript_t), SAVE :: SwanTPSMaxDescript type(OutputDataDescript_t), SAVE :: SwanWindMaxDescript type(OutputDataDescript_t), SAVE :: SwanTM02MaxDescript type(OutputDataDescript_t), SAVE :: SwanTMM10MaxDescript #endif C 3D output data type(OutputDataDescript_t), save :: SigTStaDescript ! fort.41 type(OutputDataDescript_t), save :: SalStaDescript type(OutputDataDescript_t), save :: TempStaDescript type(OutputDataDescript_t), save :: QSurfKp1Descript type(OutputDataDescript_t), save :: RealQStaDescript ! fort.42 type(OutputDataDescript_t), save :: ImaginaryQStaDescript type(OutputDataDescript_t), save :: WZStaDescript type(OutputDataDescript_t), save :: Q20StaDescript ! fort.43 type(OutputDataDescript_t), save :: LStaDescript type(OutputDataDescript_t), save :: EVStaDescript type(OutputDataDescript_t), save :: SigTDescript ! fort.44 type(OutputDataDescript_t), save :: SalDescript type(OutputDataDescript_t), save :: TempDescript type(OutputDataDescript_t), save :: RealQDescript ! fort.45 type(OutputDataDescript_t), save :: ImaginaryQDescript type(OutputDataDescript_t), save :: WZDescript type(OutputDataDescript_t), save :: Q20Descript ! fort.46 type(OutputDataDescript_t), save :: LDescript type(OutputDataDescript_t), save :: EVDescript C For hotstart files: type(OutputDataDescript_t), SAVE :: Elev1Descript type(OutputDataDescript_t), SAVE :: Elev2Descript type(OutputDataDescript_t), SAVE :: CH1Descript type(OutputDataDescript_t), SAVE :: EtaDiscDescript type(OutputDataDescript_t), SAVE :: NodeCodeDescript type(OutputDataDescript_t), SAVE :: NOFFDescript C for hotstart 3D data type(OutputDataDescript_t),SAVE :: Duudescript type(OutputDataDescript_t),SAVE :: Duvdescript type(OutputDataDescript_t),SAVE :: Dvvdescript type(OutputDataDescript_t),SAVE :: Uudescript type(OutputDataDescript_t),SAVE :: Vvdescript type(OutputDataDescript_t),SAVE :: Bsxdescript type(OutputDataDescript_t),SAVE :: Bsydescript C for hotstart harmonic analysis type(OutputDataDescript_t), SAVE :: HarmElevFDLVDescript type(OutputDataDescript_t), SAVE :: HarmElevSLVDescript type(OutputDataDescript_t), SAVE :: HarmUVelFDLVDescript type(OutputDataDescript_t), SAVE :: HarmVVelFDLVDescript type(OutputDataDescript_t), SAVE :: HarmUVelSLVDescript type(OutputDataDescript_t), SAVE :: HarmVVelSLVDescript C for hotstart harmoinc analysis means and variance calculations type(OutputDataDescript_t), SAVE :: ELAVDescript type(OutputDataDescript_t), SAVE :: ELVADescript type(OutputDataDescript_t), SAVE :: XVELAVDescript type(OutputDataDescript_t), SAVE :: YVELAVDescript type(OutputDataDescript_t), SAVE :: XVELVADescript type(OutputDataDescript_t), SAVE :: YVELVADescript C INTEGER numHotstartWrites ! number writes to hot start files INTEGER nextLun ! next LUN to write to, after initial write C !WJP 02.20.2018 Adding capability for fort.51-54 C fort.51 HaElevStaDescript % specifier = NHASE HaElevStaDescript % lun = 51 HaElevStaDescript % initial_value = 0.0 HaElevStaDescript % num_items_per_record = NHARFR HaElevStaDescript % num_fd_records = NSTAE HaElevStaDescript % num_records_this = NSTAE HaElevStaDescript % ConsiderWetDry = .TRUE. HaElevStaDescript % alternate_value = -99999.0 HaElevStaDescript % field_name = 'HaElevSta' IF (ICS.ne.1) THEN HaElevStaDescript % x_coord => SLEL HaElevStaDescript % y_coord => SFEL ELSE HaElevStaDescript % x_coord => XEL HaElevStaDescript % y_coord => YEL ENDIF HaElevStaDescript % file_extension = 51 HaElevStaDescript % file_basename = 'fort' HaElevStaDescript % readMaxMin = .false. call makeFileName(HaElevStaDescript) C C fort.52 HaVelStaDescript % specifier = NHASV HaVelStaDescript % lun = 52 HaVelStaDescript % initial_value = 0.0 HaVelStaDescript % num_items_per_record = NHARFR HaVelStaDescript % num_fd_records = NSTAV HaVelStaDescript % num_records_this = NSTAV HaVelStaDescript % ConsiderWetDry = .FALSE. HaVelStaDescript % alternate_value = 0.0 HaVelStaDescript % field_name = 'HaVelSta' IF (ICS.ne.1) THEN HaVelStaDescript % x_coord => SLEV HaVelStaDescript % y_coord => SFEV ELSE HaVelStaDescript % x_coord => XEV HaVelStaDescript % y_coord => YEV ENDIF HaVelStaDescript % file_extension = 52 HaVelStaDescript % file_basename = 'fort' HaVelStaDescript % readMaxMin = .false. call makeFileName(HaVelStaDescript) C C fort.53 HaElevDescript % specifier = NHAGE HaElevDescript % lun = 53 HaElevDescript % initial_value = 0.0 HaElevDescript % num_items_per_record = NHARFR HaElevDescript % num_fd_records = MNP HaElevDescript % num_records_this = MNP HaElevDescript % ConsiderWetDry = .TRUE. HaElevDescript % alternate_value = -99999.0 HaElevDescript % field_name = 'HaElev' HaElevDescript % file_extension = 53 HaElevDescript % file_basename = 'fort' HaElevDescript % readMaxMin = .false. call makeFileName(HaElevDescript) C C fort.54 HaVelDescript % specifier = NHAGV HaVelDescript % lun = 54 HaVelDescript % initial_value = 0.0 HaVelDescript % num_items_per_record = NHARFR HaVelDescript % num_fd_records = MNP HaVelDescript % num_records_this = MNP HaVelDescript % ConsiderWetDry = .FALSE. HaVelDescript % alternate_value = 0.0 HaVelDescript % field_name = 'HaVel' HaVelDescript % file_extension = 54 HaVelDescript % file_basename = 'fort' HaVelDescript % readMaxMin = .false. call makeFileName(HaVelDescript) C C fort.61 ElevStaDescript % specifier = NOUTE ElevStaDescript % lun = 61 ElevStaDescript % initial_value = 0.0 ElevStaDescript % num_items_per_record = 1 ElevStaDescript % num_fd_records = abs(NSTAE) ElevStaDescript % num_records_this = abs(NSTAE) ElevStaDescript % ConsiderWetDry = .TRUE. ElevStaDescript % alternate_value = -99999.0 ElevStaDescript % field_name = 'ElevSta' IF (ICS.ne.1) THEN ElevStaDescript % x_coord => SLEL ElevStaDescript % y_coord => SFEL ELSE ElevStaDescript % x_coord => XEL ElevStaDescript % y_coord => YEL ENDIF ElevStaDescript % file_extension = 61 ElevStaDescript % file_basename = 'fort' ElevStaDescript % readMaxMin = .false. call makeFileName(ElevStaDescript) C C fort.62 VelStaDescript % specifier = NOUTV VelStaDescript % lun = 62 VelStaDescript % initial_value = 0.0 VelStaDescript % num_items_per_record = 2 VelStaDescript % num_fd_records = abs(NSTAV) VelStaDescript % num_records_this = abs(NSTAV) VelStaDescript % ConsiderWetDry = .FALSE. VelStaDescript % alternate_value = 0.0 VelStaDescript % field_name = 'VelSta' IF (ICS.ne.1) THEN VelStaDescript % x_coord => SLEV VelStaDescript % y_coord => SFEV ELSE VelStaDescript % x_coord => XEV VelStaDescript % y_coord => YEV ENDIF VelStaDescript % file_extension = 62 VelStaDescript % file_basename = 'fort' VelStaDescript % readMaxMin = .false. call makeFileName(VelStaDescript) C C fort.63 ElevDescript % specifier = NOUTGE ElevDescript % lun = 63 ElevDescript % initial_value = 0.0 ElevDescript % num_items_per_record = 1 ElevDescript % num_fd_records = MNP ElevDescript % num_records_this = MNP ElevDescript % ConsiderWetDry = .TRUE. ElevDescript % alternate_value = -99999.0 ElevDescript % field_name = 'Elev' ElevDescript % file_extension = 63 ElevDescript % file_basename = 'fort' ElevDescript % readMaxMin = .false. call makeFileName(ElevDescript) C ! fort.90 (tau0) Tau0Descript % lun = 90 Tau0Descript % specifier = NOUTGE Tau0Descript % initial_value = 0.d0 Tau0Descript % num_fd_records = MNP Tau0Descript % num_records_this = MNP Tau0Descript % ConsiderWetDry = .false. Tau0Descript % alternate_value = -99999.0 Tau0Descript % field_name = 'Tau0' Tau0Descript % file_extension = 90 Tau0Descript % file_basename = 'fort' Tau0Descript % readMaxMin = .false. call makeFileName(Tau0Descript) C C fort.64 VelDescript % specifier = NOUTGV VelDescript % lun = 64 VelDescript % initial_value = 0.0 VelDescript % num_items_per_record = 2 VelDescript % num_fd_records = MNP VelDescript % num_records_this = MNP VelDescript % ConsiderWetDry = .FALSE. VelDescript % alternate_value = 0.0 VelDescript % field_name = 'Vel' VelDescript % file_extension = 64 VelDescript % file_basename = 'fort' VelDescript % readMaxMin = .false. call makeFileName(VelDescript) C C maxele.63 C jgf52.08.11: Take absolute value of specifier to avoid overwriting C (reinitializing) existing min/max file, if any. EtaMaxDescript % specifier = abs(NOUTGE) EtaMaxDescript % lun = 311 EtaMaxDescript % initial_value = -99999.d0 EtaMaxDescript % num_items_per_record = 1 EtaMaxDescript % num_fd_records = MNP EtaMaxDescript % num_records_this = MNP EtaMaxDescript % ConsiderWetDry = .FALSE. EtaMaxDescript % alternate_value = -99999.d0 EtaMaxDescript % field_name = 'EtaMax' EtaMaxDescript % file_extension = 63 EtaMaxDescript % file_basename = 'maxele' EtaMaxDescript % readMaxMin = .true. call makeFileName(EtaMaxDescript) C C maxvel.63 UMaxDescript % specifier = abs(NOUTGV) UMaxDescript % lun = 312 UMaxDescript % initial_value = 0.0 UMaxDescript % num_items_per_record = 2 UMaxDescript % num_fd_records = MNP UMaxDescript % num_records_this = MNP UMaxDescript % ConsiderWetDry = .FALSE. UMaxDescript % alternate_value = 0.0 UMaxDescript % field_name = 'UMax' UMaxDescript % file_extension = 63 UMaxDescript % file_basename = 'maxvel' UMaxDescript % readMaxMin = .true. call makeFileName(UMaxDescript) C C fort.71 PrStaDescript % specifier = NOUTM PrStaDescript % lun = 71 PrStaDescript % initial_value = 0.0 PrStaDescript % num_items_per_record = 1 PrStaDescript % num_fd_records = abs(NSTAM) PrStaDescript % num_records_this = abs(NSTAM) PrStaDescript % ConsiderWetDry = .FALSE. PrStaDescript % alternate_value = 0.0 PrStaDescript % field_name = 'PrSta' IF (ICS.ne.1) THEN PrStaDescript % x_coord => SLEM PrStaDescript % y_coord => SFEM ELSE PrStaDescript % x_coord => XEM PrStaDescript % y_coord => YEM ENDIF PrStaDescript % file_extension = 71 PrStaDescript % file_basename = 'fort' PrStaDescript % readMaxMin = .false. call makeFileName(PrStaDescript) C C fort.72 WindVelStaDescript % specifier = NOUTM WindVelStaDescript % lun = 72 WindVelStaDescript % initial_value = 0.0 WindVelStaDescript % num_items_per_record = 2 WindVelStaDescript % num_fd_records = abs(NSTAM) WindVelStaDescript % num_records_this = abs(NSTAM) WindVelStaDescript % ConsiderWetDry = .FALSE. WindVelStaDescript % alternate_value = 0.0 WindVelStaDescript % field_name = 'WindVelSta' IF (ICS.ne.1) THEN WindVelStaDescript % x_coord => SLEM WindVelStaDescript % y_coord => SFEM ELSE WindVelStaDescript % x_coord => XEM WindVelStaDescript % y_coord => YEM ENDIF WindVelStaDescript % file_extension = 72 WindVelStaDescript % file_basename = 'fort' WindVelStaDescript % readMaxMin = .false. call makeFileName(WindVelStaDescript) C C fort.73 PrDescript % specifier = NOUTGW PrDescript % lun = 73 PrDescript % initial_value = 0.0 PrDescript % num_items_per_record = 1 PrDescript % num_fd_records = MNP PrDescript % num_records_this = MNP PrDescript % ConsiderWetDry = .FALSE. PrDescript % alternate_value = 0.0 PrDescript % field_name = 'Pr' PrDescript % file_extension = 73 PrDescript % file_basename = 'fort' PrDescript % readMaxMin = .false. call makeFileName(PrDescript) C C fort.74 WindVelDescript % specifier = NOUTGW WindVelDescript % lun = 74 WindVelDescript % initial_value = 0.0 WindVelDescript % num_items_per_record = 2 WindVelDescript % num_fd_records = MNP WindVelDescript % num_records_this = MNP WindVelDescript % ConsiderWetDry = .FALSE. WindVelDescript % alternate_value = 0.0 WindVelDescript % field_name = 'WindVel' WindVelDescript % file_extension = 74 WindVelDescript % file_basename = 'fort' WindVelDescript % readMaxMin = .false. call makeFileName(WindVelDescript) C windDrag.63 windDragDescript % specifier = NOUTGW windDragDescript % lun = 173 windDragDescript % initial_value = 0.0 windDragDescript % num_items_per_record = 1 windDragDescript % num_fd_records = MNP windDragDescript % num_records_this = MNP windDragDescript % ConsiderWetDry = .FALSE. windDragDescript % alternate_value = -99999.0 windDragDescript % field_name = 'windDrag' windDragDescript % file_extension = 173 windDragDescript % file_basename = 'windDrag' windDragDescript % readMaxMin = .false. call makeFileName(windDragDescript) C fort.77 WeirElevDescript % specifier = NOUT_TVW WeirElevDescript % lun = 77 WeirElevDescript % initial_value = 0.0 WeirElevDescript % num_items_per_record = 1 WeirElevDescript % num_fd_records = MNP WeirElevDescript % num_records_this = MNP WeirElevDescript % ConsiderWetDry = .FALSE. WeirElevDescript % alternate_value = 0.0 WeirElevDescript % field_name = 'weir_dz' WeirElevDescript % file_extension = 77 WeirElevDescript % file_basename = 'fort' call makeFileName(weirElevDescript) C C minpr.63 PrMinDescript % specifier = abs(NOUTGW) PrMinDescript % lun = 313 PrMinDescript % initial_value = 99999.d0 PrMinDescript % num_items_per_record = 1 PrMinDescript % num_fd_records = MNP PrMinDescript % num_records_this = MNP PrMinDescript % ConsiderWetDry = .FALSE. PrMinDescript % alternate_value = 0.0 PrMinDescript % field_name = 'PrMin' PrMinDescript % file_extension = 63 PrMinDescript % file_basename = 'minpr' PrMinDescript % readMaxMin = .true. call makeFileName(PrMinDescript) C C maxwvel.63 WVMaxDescript % specifier = abs(NOUTGW) WVMaxDescript % lun = 314 WVMaxDescript % initial_value = 0.0 WVMaxDescript % num_items_per_record = 2 WVMaxDescript % num_fd_records = MNP WVMaxDescript % num_records_this = MNP WVMaxDescript % ConsiderWetDry = .FALSE. WVMaxDescript % alternate_value = 0.0 WVMaxDescript % field_name = 'WVMax' WVMaxDescript % file_extension = 63 WVMaxDescript % file_basename = 'maxwvel' WVMaxDescript % readMaxMin = .true. call makeFileName(WVMaxDescript) RSMaxDescript % specifier = abs(NOUTGW) RSMaxDescript % lun = 315 RSMaxDescript % initial_value = 0.0 RSMaxDescript % num_items_per_record = 2 RSMaxDescript % num_fd_records = MNP RSMaxDescript % num_records_this = MNP RSMaxDescript % ConsiderWetDry = .FALSE. RSMaxDescript % alternate_value = 0.0 RSMaxDescript % field_name = "RSMax" RSMaxDescript % file_name = "maxrs.63" RSMaxDescript % file_extension = 63 RSMaxDescript % file_basename = 'maxrs' RSMaxDescript % readMaxMin = .true. call makeFileName(RSMaxDescript) ! tcm v50.75 removed ifdef adcswan to allow for use whenever nrs=3 or nrs=4 or nrs=5 !#ifdef ADCSWAN Cobell 20120510: SWAN Output Data C........Radiation Stress RSDescript % specifier = NOUTGW RSDescript % lun = 164 RSDescript % initial_value = 0.0 RSDescript % num_items_per_record = 2 RSDescript % num_fd_records = MNP RSDescript % num_records_this = MNP RSDescript % ConsiderWetDry = .FALSE. RSDescript % alternate_value = -99999.0 RSDescript % field_name = "rads" RSDescript % file_name = "rads.64" RSDescript % file_extension = 64 RSDescript % file_basename = 'rads' RSDescript % readMaxMin = .false. call makeFileName(RSDescript) ! ! D E T A I L E D I N U N D A T I O N O U T P U T ! ! inundationtime.63 (works like a min/max file) InundationTimeDescript % lun = 400 InundationTimeDescript % specifier = abs(NOUTGE) InundationTimeDescript % num_items_per_record = 1 InundationTimeDescript % initial_value = 0.0 InundationTimeDescript % num_fd_records = MNP InundationTimeDescript % num_records_this = MNP InundationTimeDescript % ConsiderWetDry = .false. InundationTimeDescript % alternate_value = 0.0 InundationTimeDescript % field_name = 'inundationTime' InundationTimeDescript % file_basename = 'inundationtime' InundationTimeDescript % file_extension = 63 InundationTimeDescript % readMaxMin = .true. if ( InundationTimeDescript % specifier .eq. XDMF ) then InundationTimeDescript % specifier = ASCII endif call makeFileName(InundationTimeDescript) ! ! maxinundepth.63 (works like a min/max file) MaxInunDepthDescript % lun = 401 MaxInunDepthDescript % specifier = abs(NOUTGE) MaxInunDepthDescript % initial_value = 0.0 MaxInunDepthDescript % num_fd_records = MNP MaxInunDepthDescript % num_records_this = MNP MaxInunDepthDescript % ConsiderWetDry = .false. MaxInunDepthDescript % alternate_value = 0.0 MaxInunDepthDescript % num_items_per_record = 1 MaxInunDepthDescript % field_name = 'maxInunDepth' MaxInunDepthDescript % file_basename = 'maxinundepth' MaxInunDepthDescript % file_extension = 63 MaxInunDepthDescript % readMaxMin = .true. if ( MaxInunDepthDescript % specifier .eq. XDMF ) then MaxInunDepthDescript % specifier = ASCII endif call makeFileName(MaxInunDepthDescript) ! ! initiallydry.63 (nodes that are deemed dry upon cold start) InitiallyDryDescript % lun = 402 InitiallyDryDescript % specifier = NOUTGE InitiallyDryDescript % initial_value = 0.0 InitiallyDryDescript % num_fd_records = MNP InitiallyDryDescript % num_records_this = MNP InitiallyDryDescript % ConsiderWetDry = .false. InitiallyDryDescript % alternate_value = 0.0 InitiallyDryDescript % num_items_per_record = 1 InitiallyDryDescript % field_name = 'initiallyDry' InitiallyDryDescript % file_basename = 'initiallydry' InitiallyDryDescript % file_extension = 63 InitiallyDryDescript % isInteger = .true. if ( InitiallyDryDescript % specifier .eq. XDMF ) then InitiallyDryDescript % specifier = ASCII endif call makeFileName(InitiallyDryDescript) ! ! endrisinginun.63 (1 if water is rising at end of simulation) EndRisingInunDescript % lun = 403 EndRisingInunDescript % specifier = NOUTGE EndRisingInunDescript % initial_value = 0.0 EndRisingInunDescript % num_fd_records = MNP EndRisingInunDescript % num_records_this = MNP EndRisingInunDescript % ConsiderWetDry = .false. EndRisingInunDescript % alternate_value = 0.0 EndRisingInunDescript % num_items_per_record = 1 EndRisingInunDescript % field_name = 'endRisingInun' EndRisingInunDescript % file_basename = 'endrisinginun' EndRisingInunDescript % file_extension = 63 EndRisingInunDescript % isInteger = .true. if ( EndRisingInunDescript % specifier .eq. XDMF ) then EndRisingInunDescript % specifier = ASCII endif call makeFileName(EndRisingInunDescript) ! ! everdried.63 (works like a min/max file) EverDriedDescript % lun = 404 EverDriedDescript % specifier = abs(NOUTGE) EverDriedDescript % num_items_per_record = 1 EverDriedDescript % initial_value = 0.0 EverDriedDescript % num_fd_records = MNP EverDriedDescript % num_records_this = MNP EverDriedDescript % ConsiderWetDry = .false. EverDriedDescript % alternate_value = -99999.d0 EverDriedDescript % field_name = 'EverDried' EverDriedDescript % file_basename = 'everdried' EverDriedDescript % file_extension = 63 EverDriedDescript % readMaxMin = .true. if ( EverDriedDescript % specifier .eq. XDMF ) then EverDriedDescript % specifier = ASCII endif call makeFileName(EverDriedDescript) weirElevDescript % specifier = NOUT_TVW weirElevDescript % initial_value = 0D0 weirElevDescript % num_items_per_record = 1 weirElevDescript % num_fd_records = MNP weirElevDescript % num_records_this = MNP weirElevDescript % ConsiderWetDry = .FALSE. weirElevDescript % alternate_value = 0D0 weirElevDescript % field_name = "weir_dz" weirElevDescript % file_name = "fort.77" C C dynamicWaterlevelCorrection.61 dynamicWaterlevelCorrectionStaDescript % specifier = NOUTE dynamicWaterlevelCorrectionStaDescript % lun = 109 dynamicWaterlevelCorrectionStaDescript % initial_value = 0.0 dynamicWaterlevelCorrectionStaDescript % num_items_per_record = 1 dynamicWaterlevelCorrectionStaDescript % num_fd_records = abs(NSTAE) dynamicWaterlevelCorrectionStaDescript % num_records_this = abs(NSTAE) dynamicWaterlevelCorrectionStaDescript % alternate_value = -99999.0 dynamicWaterlevelCorrectionStaDescript % field_name = 'dynamicWaterlevelCorrection' IF (ICS.ne.1) THEN dynamicWaterlevelCorrectionStaDescript % x_coord => SLEL dynamicWaterlevelCorrectionStaDescript % y_coord => SFEL ELSE dynamicWaterlevelCorrectionStaDescript % x_coord => XEL dynamicWaterlevelCorrectionStaDescript % y_coord => YEL ENDIF dynamicWaterlevelCorrectionStaDescript % file_extension = 61 dynamicWaterlevelCorrectionStaDescript % file_basename = 'dynamicWaterlevelCorrection' dynamicWaterlevelCorrectionStaDescript % readMaxMin = .false. dynamicWaterlevelCorrectionStaDescript % considerWetDry = .false. call makeFileName(dynamicWaterlevelCorrectionStaDescript) C C dynamicWaterlevelCorrection.63 dynamicWaterlevelCorrectionDescript % specifier = NOUTGE dynamicWaterlevelCorrectionDescript % lun = 108 dynamicWaterlevelCorrectionDescript % initial_value = 0.0 dynamicWaterlevelCorrectionDescript % num_items_per_record = 1 dynamicWaterlevelCorrectionDescript % num_fd_records = MNP dynamicWaterlevelCorrectionDescript % num_records_this = MNP dynamicWaterlevelCorrectionDescript % alternate_value = -99999.0 dynamicWaterlevelCorrectionDescript % field_name = 'dynamicWaterlevelCorrection' dynamicWaterlevelCorrectionDescript % file_extension = 63 dynamicWaterlevelCorrectionDescript % file_basename = 'dynamicWaterlevelCorrection' dynamicWaterlevelCorrectionDescript % readMaxMin = .false. dynamicWaterlevelCorrectionDescript % considerWetDry = .false. call makeFileName(dynamicWaterlevelCorrectionDescript) ! tcm v50.75 moved the ifdef adcswan down past the RSDescript #ifdef ADCSWAN C........Significant Wave Height (HS) SwanHSDescript % specifier = NOUTGW SwanHSDescript % lun = 301 SwanHSDescript % initial_value = 0.0 SwanHSDescript % num_items_per_record = 1 SwanHSDescript % num_fd_records = MNP SwanHSDescript % num_records_this = MNP SwanHSDescript % ConsiderWetDry = .FALSE. SwanHSDescript % alternate_value = -99999.0 SwanHSDescript % field_name = "swan_HS" SwanHSDescript % file_name = "swan_HS.63" SwanHSDescript % file_extension = 63 SwanHSDescript % file_basename = 'swan_HS' call makeFileName(SwanHSDescript) SwanHSMaxDescript % specifier = NOUTGW SwanHSMaxDescript % lun = 316 SwanHSMaxDescript % initial_value = 0.0 SwanHSMaxDescript % num_items_per_record = 1 SwanHSMaxDescript % num_fd_records = MNP SwanHSMaxDescript % num_records_this = MNP SwanHSMaxDescript % ConsiderWetDry = .FALSE. SwanHSMaxDescript % alternate_value = -99999.0 SwanHSMaxDescript % field_name = "swan_HS_max" SwanHSMaxDescript % file_name = "swan_HS_max.63" SwanHSMaxDescript % file_extension = 63 SwanHSMaxDescript % file_basename = 'swan_HS_max' call makeFileName(SwanHSMaxDescript) C........Mean Wave Direction (DIR) SwanDIRDescript % specifier = NOUTGW SwanDIRDescript % lun = 302 SwanDIRDescript % initial_value = 0.0 SwanDIRDescript % num_items_per_record = 1 SwanDIRDescript % num_fd_records = MNP SwanDIRDescript % num_records_this = MNP SwanDIRDescript % ConsiderWetDry = .FALSE. SwanDIRDescript % alternate_value = -99999.0 SwanDIRDescript % field_name = "swan_DIR" SwanDIRDescript % file_name = "swan_DIR.63" SwanDIRDescript % file_extension = 63 SwanDIRDescript % file_basename = 'swan_DIR' call makeFileName(SwanDIRDescript) SwanDIRMaxDescript % specifier = NOUTGW SwanDIRMaxDescript % lun = 317 SwanDIRMaxDescript % initial_value = 0.0 SwanDIRMaxDescript % num_items_per_record = 1 SwanDIRMaxDescript % num_fd_records = MNP SwanDIRMaxDescript % num_records_this = MNP SwanDIRMaxDescript % ConsiderWetDry = .FALSE. SwanDIRMaxDescript % alternate_value = -99999.0 SwanDIRMaxDescript % field_name = "swan_DIR_max" SwanDIRMaxDescript % file_name = "swan_DIR_max.63" SwanDIRMaxDescript % file_extension = 63 SwanDIRMaxDescript % file_basename = 'swan_DIR_max' call makeFileName(SwanDIRMaxDescript) C........Mean Wave Period (TM01) SwanTM01Descript % specifier = NOUTGW SwanTM01Descript % lun = 303 SwanTM01Descript % initial_value = 0.0 SwanTM01Descript % num_items_per_record = 1 SwanTM01Descript % num_fd_records = MNP SwanTM01Descript % num_records_this = MNP SwanTM01Descript % ConsiderWetDry = .FALSE. SwanTM01Descript % alternate_value = -99999.0 SwanTM01Descript % field_name = "swan_TM01" SwanTM01Descript % file_name = "swan_TM01.63" SwanTM01Descript % file_extension = 63 SwanTM01Descript % file_basename = 'swan_TM01' call makeFileName(SwanTM01Descript) SwanTM01MaxDescript % specifier = NOUTGW SwanTM01MaxDescript % lun = 318 SwanTM01MaxDescript % initial_value = 0.0 SwanTM01MaxDescript % num_items_per_record = 1 SwanTM01MaxDescript % num_fd_records = MNP SwanTM01MaxDescript % num_records_this = MNP SwanTM01MaxDescript % ConsiderWetDry = .FALSE. SwanTM01MaxDescript % alternate_value = -99999.0 SwanTM01MaxDescript % field_name = "swan_TM01_max" SwanTM01MaxDescript % file_name = "swan_TM01_max.63" SwanTM01MaxDescript % file_extension = 63 SwanTM01MaxDescript % file_basename = 'swan_TM01_max' call makeFileName(SwanTM01MaxDescript) C........Peak Wave Period (TPS) SwanTPSDescript % specifier = NOUTGW SwanTPSDescript % lun = 304 SwanTPSDescript % initial_value = 0.0 SwanTPSDescript % num_items_per_record = 1 SwanTPSDescript % num_fd_records = MNP SwanTPSDescript % num_records_this = MNP SwanTPSDescript % ConsiderWetDry = .FALSE. SwanTPSDescript % alternate_value = -99999.0 SwanTPSDescript % field_name = "Swan_TPS" SwanTPSDescript % file_name = "swan_TPS.63" SwanTPSDescript % file_extension = 63 SwanTPSDescript % file_basename = 'swan_TPS' call makeFileName(SwanTPSDescript) SwanTPSMaxDescript % specifier = NOUTGW SwanTPSMaxDescript % lun = 319 SwanTPSMaxDescript % initial_value = 0.0 SwanTPSMaxDescript % num_items_per_record = 1 SwanTPSMaxDescript % num_fd_records = MNP SwanTPSMaxDescript % num_records_this = MNP SwanTPSMaxDescript % ConsiderWetDry = .FALSE. SwanTPSMaxDescript % alternate_value = -99999.0 SwanTPSMaxDescript % field_name = "Swan_TPS_max" SwanTPSMaxDescript % file_name = "swan_TPS_max.63" SwanTPSMaxDescript % file_extension = 63 SwanTPSMaxDescript % file_basename = 'swan_TPS_max' call makeFileName(SwanTPSMaxDescript) C........SWAN Wind Values (WINDX,WINDY) SwanWindDescript % specifier = NOUTGW SwanWindDescript % lun = 305 SwanWindDescript % initial_value = 0.0 SwanWindDescript % num_items_per_record = 2 SwanWindDescript % num_fd_records = MNP SwanWindDescript % num_records_this = MNP SwanWindDescript % ConsiderWetDry = .FALSE. SwanWindDescript % alternate_value = -99999.0 SwanWindDescript % field_name = "swan_WIND" SwanWindDescript % file_name = "swan_WIND.64" SwanWindDescript % file_extension = 64 SwanWindDescript % file_basename = 'swan_WIND' call makeFileName(SwanWindDescript) SwanWindMaxDescript % specifier = NOUTGW SwanWindMaxDescript % lun = 320 SwanWindMaxDescript % initial_value = 0.0 SwanWindMaxDescript % num_items_per_record = 1 SwanWindMaxDescript % num_fd_records = MNP SwanWindMaxDescript % num_records_this = MNP SwanWindMaxDescript % ConsiderWetDry = .FALSE. SwanWindMaxDescript % alternate_value = -99999.0 SwanWindMaxDescript % field_name = "swan_WIND_max" SwanWindMaxDescript % file_name = "swan_WIND_max.63" SwanWindMaxDescript % file_extension = 63 SwanWindMaxDescript % file_basename = 'swan_WIND_max' call makeFileName(SwanWindMaxDescript) C........Mean Wave Period (TM02) SwanTM02Descript % specifier = NOUTGW SwanTM02Descript % lun = 306 SwanTM02Descript % initial_value = 0.0 SwanTM02Descript % num_items_per_record = 1 SwanTM02Descript % num_fd_records = MNP SwanTM02Descript % num_records_this = MNP SwanTM02Descript % ConsiderWetDry = .FALSE. SwanTM02Descript % alternate_value = -99999.0 SwanTM02Descript % field_name = "swan_TM02" SwanTM02Descript % file_name = "swan_TM02.63" SwanTM02Descript % file_extension = 63 SwanTM02Descript % file_basename = 'swan_TM02' call makeFileName(SwanTM02Descript) SwanTM02MaxDescript % specifier = NOUTGW SwanTM02MaxDescript % lun = 321 SwanTM02MaxDescript % initial_value = 0.0 SwanTM02MaxDescript % num_items_per_record = 1 SwanTM02MaxDescript % num_fd_records = MNP SwanTM02MaxDescript % num_records_this = MNP SwanTM02MaxDescript % ConsiderWetDry = .FALSE. SwanTM02MaxDescript % alternate_value = -99999.0 SwanTM02MaxDescript % field_name = "swan_TM02_max" SwanTM02MaxDescript % file_name = "swan_TM02_max.63" SwanTM02MaxDescript % file_extension = 63 SwanTM02MaxDescript % file_basename = 'swan_TM02_max' call makeFileName(SwanTM02MaxDescript) C........Mean Wave Period (TMM10) SwanTMM10Descript % specifier = NOUTGW SwanTMM10Descript % lun = 307 SwanTMM10Descript % initial_value = 0.0 SwanTMM10Descript % num_items_per_record = 1 SwanTMM10Descript % num_fd_records = MNP SwanTMM10Descript % num_records_this = MNP SwanTMM10Descript % ConsiderWetDry = .FALSE. SwanTMM10Descript % alternate_value = -99999.0 SwanTMM10Descript % field_name = "swan_TMM10" SwanTMM10Descript % file_name = "swan_TMM10.63" SwanTMM10Descript % file_extension = 63 SwanTMM10Descript % file_basename = 'swan_TMM10' call makeFileName(SwanTMM10Descript) SwanTMM10MaxDescript % specifier = NOUTGW SwanTMM10MaxDescript % lun = 322 SwanTMM10MaxDescript % initial_value = 0.0 SwanTMM10MaxDescript % num_items_per_record = 1 SwanTMM10MaxDescript % num_fd_records = MNP SwanTMM10MaxDescript % num_records_this = MNP SwanTMM10MaxDescript % ConsiderWetDry = .FALSE. SwanTMM10MaxDescript % alternate_value = -99999.0 SwanTMM10MaxDescript % field_name = "swan_TMM10_max" SwanTMM10MaxDescript % file_name = "swan_TMM10_max.63" SwanTMM10MaxDescript % file_extension = 63 SwanTMM10MaxDescript % file_basename = 'swan_TMM10_max' call makeFileName(SwanTMM10MaxDescript) #endif C 3D data C fort.41 SigTStaDescript % specifier = I3DSD SigTStaDescript % lun = 41 SigTStaDescript % initial_value = 0.0 SigTStaDescript % num_items_per_record = NFEN SigTStaDescript % num_fd_records = NSTA3DD SigTStaDescript % num_records_this = NSTA3DD SigTStaDescript % field_name = 'SigmaTStations' IF (ICS.ne.1) THEN SigTStaDescript % x_coord => SL3DD SigTStaDescript % y_coord => SF3DD ELSE SigTStaDescript % x_coord => X3DD SigTStaDescript % y_coord => Y3DD ENDIF SigTStaDescript % file_extension = 41 SigTStaDescript % file_basename = 'fort' call makeFileName(SigTStaDescript) SalStaDescript % specifier = I3DSD SalStaDescript % lun = 41 SalStaDescript % initial_value = 0.0 SalStaDescript % num_items_per_record = NFEN SalStaDescript % num_fd_records = NSTA3DD SalStaDescript % num_records_this = NSTA3DD SalStaDescript % field_name = 'SalinityStations' IF (ICS.ne.1) THEN SalStaDescript % x_coord => SL3DD SalStaDescript % y_coord => SF3DD ELSE SalStaDescript % x_coord => X3DD SalStaDescript % y_coord => Y3DD ENDIF TempStaDescript % specifier = I3DSD TempStaDescript % lun = 41 TempStaDescript % initial_value = 0.0 TempStaDescript % num_items_per_record = NFEN TempStaDescript % num_fd_records = NSTA3DD TempStaDescript % num_records_this = NSTA3DD TempStaDescript % field_name = 'TemperatureStations' IF (ICS.ne.1) THEN TempStaDescript % x_coord => SL3DD TempStaDescript % y_coord => SF3DD ELSE TempStaDescript % x_coord => X3DD TempStaDescript % y_coord => Y3DD ENDIF C C fort.42 RealQStaDescript % specifier = I3DSV RealQStaDescript % lun = 42 RealQStaDescript % initial_value = 0.0 RealQStaDescript % num_items_per_record = NFEN RealQStaDescript % num_fd_records = NSta3DV RealQStaDescript % num_records_this = NSta3DV RealQStaDescript % field_name = 'RealQStations' IF (ICS.ne.1) THEN RealQStaDescript % x_coord => SL3DV RealQStaDescript % y_coord => SF3DV ELSE RealQStaDescript % x_coord => X3DV RealQStaDescript % y_coord => Y3DV ENDIF RealQStaDescript % file_extension = 42 RealQStaDescript % file_basename = 'fort' call makeFileName(RealQStaDescript) ImaginaryQStaDescript % specifier = I3DSV ImaginaryQStaDescript % lun = 42 ImaginaryQStaDescript % initial_value = 0.0 ImaginaryQStaDescript % num_items_per_record = NFEN ImaginaryQStaDescript % num_fd_records = NSTA3DV ImaginaryQStaDescript % num_records_this = NSTA3DV ImaginaryQStaDescript % field_name ='ImaginaryQStations' IF (ICS.ne.1) THEN ImaginaryQStaDescript % x_coord => SL3DV ImaginaryQStaDescript % y_coord => SF3DV ELSE ImaginaryQStaDescript % x_coord => X3DV ImaginaryQStaDescript % y_coord => Y3DV ENDIF WZStaDescript % specifier = I3DSV WZStaDescript % lun = 42 WZStaDescript % initial_value = 0.0 WZStaDescript % num_items_per_record = NFEN WZStaDescript % num_fd_records = NSTA3DV WZStaDescript % num_records_this = NSTA3DV WZStaDescript % field_name = 'WZStations' IF (ICS.ne.1) THEN WZStaDescript % x_coord => SL3DV WZStaDescript % y_coord => SF3DV ELSE WZStaDescript % x_coord => X3DV WZStaDescript % y_coord => Y3DV ENDIF C C fort.43 Q20StaDescript % specifier = I3DST Q20StaDescript % lun = 43 Q20StaDescript % initial_value = 0.0 Q20StaDescript % num_items_per_record = NFEN Q20StaDescript % num_fd_records = NSta3DT Q20StaDescript % num_records_this = NSta3DT Q20StaDescript % field_name = 'q20Stations' IF (ICS.ne.1) THEN Q20StaDescript % x_coord => SL3DT Q20StaDescript % y_coord => SF3DT ELSE Q20StaDescript % x_coord => X3DT Q20StaDescript % y_coord => Y3DT ENDIF Q20StaDescript % file_extension = 43 Q20StaDescript % file_basename = 'fort' call makeFileName(Q20StaDescript) LStaDescript % specifier = I3DST LStaDescript % lun = 43 LStaDescript % initial_value = 0.0 LStaDescript % num_items_per_record = NFEN LStaDescript % num_fd_records = NSTA3DT LStaDescript % num_records_this = NSTA3DT LStaDescript % field_name = 'LStations' IF (ICS.ne.1) THEN LStaDescript % x_coord => SL3DT LStaDescript % y_coord => SF3DT ELSE LStaDescript % x_coord => X3DT LStaDescript % y_coord => Y3DT ENDIF EVStaDescript % specifier = I3DST EVStaDescript % lun = 43 EVStaDescript % initial_value = 0.0 EVStaDescript % num_items_per_record = NFEN EVStaDescript % num_fd_records = NSTA3DT EVStaDescript % num_records_this = NSTA3DT EVStaDescript % field_name = 'EVStations' IF (ICS.ne.1) THEN EVStaDescript % x_coord => SL3DT EVStaDescript % y_coord => SF3DT ELSE EVStaDescript % x_coord => X3DT EVStaDescript % y_coord => Y3DT ENDIF C C fort.44 SigTDescript % specifier = I3DGD SigTDescript % lun = 44 SigTDescript % initial_value = 0.0 SigTDescript % num_items_per_record = NFEN SigTDescript % num_fd_records = MNP SigTDescript % num_records_this = MNP SigTDescript % field_name = 'SigmaT' SigTDescript % file_extension = 44 SigTDescript % file_basename = 'fort' call makeFileName(SigTDescript) SalDescript % specifier = I3DGD SalDescript % lun = 44 SalDescript % initial_value = 0.0 SalDescript % num_items_per_record = NFEN SalDescript % num_fd_records = MNP SalDescript % num_records_this = MNP SalDescript % field_name = 'Salinity' TempDescript % specifier = I3DGD TempDescript % lun = 44 TempDescript % initial_value = 0.0 TempDescript % num_items_per_record = NFEN TempDescript % num_fd_records = MNP TempDescript % num_records_this = MNP TempDescript % field_name = 'Temperature' C C fort.45 RealQDescript % specifier = I3DGV RealQDescript % lun = 45 RealQdescript % initial_value = 0.0 RealQDescript % num_items_per_record = NFEN RealQDescript % num_fd_records = MNP RealQDescript % num_records_this = MNP RealQDescript % field_name = 'RealQ' RealQDescript % file_extension = 45 RealQDescript % file_basename = 'fort' call makeFileName(RealQDescript) ImaginaryQDescript % specifier = I3DGV ImaginaryQDescript % lun = 45 ImaginaryQDescript % initial_value = 0.0 ImaginaryQDescript % num_items_per_record = NFEN ImaginaryQDescript % num_fd_records = MNP ImaginaryQDescript % num_records_this = MNP ImaginaryQDescript % field_name = 'ImaginaryQ' WZDescript % specifier = I3DGV WZDescript % lun = 45 WZDescript % initial_value = 0.0 WZDescript % num_items_per_record = NFEN WZDescript % num_fd_records = MNP WZDescript % num_records_this = MNP WZDescript % field_name = 'WZ' C C fort.46 Q20Descript % specifier = I3DGT Q20Descript % lun = 46 Q20Descript % initial_value = 0.0 Q20Descript % num_items_per_record = NFEN Q20Descript % num_fd_records = MNP Q20Descript % num_records_this = MNP Q20Descript % field_name = 'q20' Q20Descript % file_extension = 46 Q20Descript % file_basename = 'fort' call makeFileName(Q20Descript) LDescript % specifier = I3DGT LDescript % lun = 46 LDescript % initial_value = 0.0 LDescript % num_items_per_record = NFEN LDescript % num_fd_records = MNP LDescript % num_records_this = MNP LDescript % field_name = 'L' EVDescript % specifier = I3DGT EVDescript % lun = 46 EVDescript % initial_value = 0.0 EVDescript % num_items_per_record = NFEN EVDescript % num_fd_records = MNP EVDescript % num_records_this = MNP EVDescript % field_name = 'EV' C C fort.47 QSurfKp1Descript % specifier = I3DGD QSurfKp1Descript % lun = 47 QSurfKp1Descript % initial_value = 0.0 QSurfKp1Descript % num_items_per_record = 1 QSurfKp1Descript % num_fd_records = MNP QSurfKp1Descript % num_records_this = MNP QSurfKp1Descript % field_name = 'qsurfkp1' call makeFileName(QSurfKp1Descript) C C fort.67 and fort.68 Elev1Descript % specifier = NHSTAR Elev1Descript % initial_value = 0.0 Elev1Descript % file_basename = 'fort' Elev1Descript % file_extension = 67 call makeFileName(Elev1Descript) Elev2Descript % specifier = NHSTAR Elev2Descript % initial_value = 0.0 CH1Descript % specifier = NHSTAR CH1Descript % initial_value = 0.0 EtaDiscDescript % specifier = NHSTAR EtaDiscDescript % initial_value = 0.0 NodeCodeDescript % specifier = NHSTAR NodeCodeDescript % initial_value = 0.d0 NOFFDescript % specifier = NHSTAR NOFFDescript % initial_value = 0.d0 C hotstart 3D Duudescript % specifier = NHSTAR Duudescript % initial_value = 0.0 Duudescript % num_items_per_record = 1 Duudescript % num_fd_records = MNP Duudescript % num_records_this = MNP Duvdescript % specifier = NHSTAR Duvdescript % initial_value = 0.0 Duvdescript % num_items_per_record = 1 Duvdescript % num_fd_records = MNP Duvdescript % num_records_this = MNP Dvvdescript % specifier = NHSTAR Dvvdescript % initial_value = 0.0 Dvvdescript % num_items_per_record = 1 Dvvdescript % num_fd_records = MNP Dvvdescript % num_records_this = MNP Uudescript % specifier = NHSTAR Uudescript % initial_value = 0.0 Uudescript % num_items_per_record = 1 Uudescript % num_fd_records = MNP Uudescript % num_records_this = MNP Vvdescript % specifier = NHSTAR Vvdescript % initial_value = 0.0 Vvdescript % num_items_per_record = 1 Vvdescript % num_fd_records = MNP Vvdescript % num_records_this = MNP Bsxdescript % specifier = NHSTAR Bsxdescript % initial_value = 0.0 Bsxdescript % num_items_per_record = 1 Bsxdescript % num_fd_records = MNP Bsxdescript % num_records_this = MNP Bsydescript % specifier = NHSTAR Bsydescript % initial_value = 0.0 Bsydescript % num_items_per_record = 1 Bsydescript % num_fd_records = MNP Bsydescript % num_records_this = MNP C hotstart harmonic analysis HarmElevFDLVDescript % specifier = NHSTAR HarmElevFDLVDescript % initial_value = 0.0 HarmElevFDLVDescript % num_fd_records = MNP HarmElevSLVDescript % specifier = NHSTAR HarmElevSLVDescript % initial_value = 0.0 HarmElevSLVDescript % num_fd_records = abs(NSTAE) HarmUVelFDLVDescript % specifier = NHSTAR HarmUVelFDLVDescript % initial_value = 0.0 HarmUVelFDLVDescript % num_fd_records = MNP HarmVVelFDLVDescript % specifier = NHSTAR HarmVVelFDLVDescript % initial_value = 0.0 HarmVVelFDLVDescript % num_fd_records = MNP HarmUvelSLVDescript % specifier = NHSTAR HarmUVelSLVDescript % initial_value = 0.0 HarmUVelSLVDescript % num_fd_records = abs(NSTAV) HarmVVelSLVDescript % specifier = NHSTAR HarmVVelSLVDescript % initial_value = 0.0 HarmVVelSLVDescript % num_fd_records = abs(NSTAV) C hotstart means and variance calculations ELAVDescript % specifier = NHSTAR ELAVDescript % initial_value = 0.0 ELAVDescript % num_fd_records = MNP ELVADescript % specifier = NHSTAR ELVADescript % initial_value = 0.0 ELVADescript % num_fd_records = MNP XVELAVDescript % specifier = NHSTAR XVELAVDescript % initial_value = 0.0 XVELAVDescript % num_fd_records = MNP YVELAVDescript % specifier = NHSTAR YVELAVDescript % initial_value = 0.0 YVELAVDescript % num_fd_records = MNP XVELVADescript % specifier = NHSTAR XVELVADescript % initial_value = 0.0 XVELVADescript % num_fd_records = MNP YVELVADescript % specifier = NHSTAR YVELVADescript % initial_value = 0.0 YVELVADescript % num_fd_records = MNP C C Need to populate the global and nodal attributes modules with C these parameters, since the netcdfio module relies on those C modules, rather than the pre_global module. Some day, adcprep C will be integrated with ADCIRC and this subroutine call will C not be needed. IF (.not.ALLOCATED(NODECODE)) THEN ALLOCATE(NODECODE(MNP)) ENDIF C C jgf49.44: Set parameters in global module based on the data C we collected in read_global.F and stored in pre_global.F. CALL setADCIRCParameters( & base_date, MNE, NBOU, & NVEL, NOPE, MNP, SL0, SF0, NBVV, NVDLL, NBDV, NVELL, X, Y, & IBTYPE, IBTYPEE, SL1, SF1, NODECODE, G, FileFmtRev, & FileFmtMinor, FileFmtMajor, im, iestp, nscoue, ivstp, nscouv, & icstp, nscouc, ipstp, iwstp, nscoum, igep, nscouge, igvp, & nscougv, igcp, nscougc, igpp, igwp, nscougw, NM, & DP, RUNDES, AGRID, title, institution, source, history, & references, comments, host, convention, contact, DT, ihot, & ics, nolifa, nolica, nolicat, ncor, ntip, nws, nramp, statim, & reftim, rnday, dramp, a00, b00, c00, h0, cori, ntif, nbfr, & myProc, screenUnit, nolibf, nwp, tau0, cf, eslm, & abs(nstae), abs(nstav), abs(nstam), neta, nabout, nscreen, & nfen, iden, islip, kp, z0s, z0b, theta1, theta2, & ievc, evmin, evcon, alp1, alp2, alp3, igc, nlsd, nvsd, nltd, & nvtd, alp4, C3D, runid) C C Create NetCDF output files for those output files where NetCDF C was specified. reterr = .false. !WJP 02.20.2018 Adding capability for fort.51-54 CALL initNetCDFOutputFile(HaElevStaDescript, reterr) CALL initNetCDFOutputFile(HaVelStaDescript, reterr) CALL initNetCDFOutputFile(HaElevDescript, reterr) CALL initNetCDFOutputFile(HaVelDescript, reterr) CALL initNetCDFOutputFile(ElevStaDescript, reterr) CALL initNetCDFOutputFile(VelStaDescript, reterr) CALL initNetCDFOutputFile(ElevDescript, reterr) if (outputTau0.eqv..true.) then CALL initNetCDFOutputFile(Tau0Descript, reterr) endif CALL initNetCDFOutputFile(VelDescript, reterr) CALL initNetCDFOutputFile(PrStaDescript, reterr) CALL initNetCDFOutputFile(WindVelStaDescript, reterr) CALL initNetCDFOutputFile(PrDescript, reterr) CALL initNetCDFOutputFile(WindVelDescript, reterr) CALL initNetCDFOutputFile(WeirElevDescript, reterr) CALL initNetCDFOutputFile(EtaMaxDescript, reterr) CALL initNetCDFOutputFile(UMaxDescript, reterr) CALL initNetCDFOutputFile(PrMinDescript, reterr) CALL initNetCDFOutputFile(WVMaxDescript, reterr) CALL initNetCDFOutputFile(RSMaxDescript,reterr) if (inundationOutput.eqv..true.) then CALL initNetCDFOutputFile(InundationTimeDescript,reterr) CALL initNetCDFOutputFile(MaxInunDepthDescript,reterr) CALL initNetCDFOutputFile(InitiallyDryDescript,reterr) CALL initNetCDFOutputFile(EndRisingInunDescript,reterr) CALL initNetCDFOutputFile(EverDriedDescript,reterr) endif if (outputWindDrag.eqv..true.)then CALL initNetCDFOutputFile(windDragDescript,reterr) endif if ( foundCorrectionControlNamelist.eqv..true. ) then if ( NOUTE.ne.0 ) then CALL initNetCDFOutputFile(dynamicWaterlevelCorrectionStaDescript,reterr) endif if ( NOUTGE.ne.0 ) then CALL initNetCDFOutputFile(dynamicWaterlevelCorrectionDescript,reterr) endif endif ! ! tcm v50.75 moved ifdef adcswan below RSDescript only to allow ! for use whenever nrs=3 or nrs=4 or nrs=5 ! Cobell 20120510: Added for SWAN NetCDF IF ((NRS.EQ.3).OR.(NRS.EQ.4).OR.(NRS.EQ.5)) THEN CALL initNetCDFOutputFile(RSDescript,reterr) ENDIF ! tcm v50.75 moved ifdef adcswan to here #ifdef ADCSWAN ! Cobell 20120510: Added for SWAN NetCDF IF(NRS.EQ.3)THEN IF(SWAN_OutputHS)THEN CALL initNetCDFOutputFile(SwanHSDescript,reterr) CALL initNetCDFOutputFile(SwanHSMaxDescript,reterr) ENDIF IF(SWAN_OutputDIR)THEN CALL initNetCDFOutputFile(SwanDIRDescript,reterr) CALL initNetCDFOutputFile(SwanDIRMaxDescript,reterr) ENDIF IF(SWAN_OutputTM01)THEN CALL initNetCDFOutputFile(SwanTM01Descript,reterr) CALL initNetCDFOutputFile(SwanTM01MaxDescript,reterr) ENDIF IF(SWAN_OutputTPS)THEN CALL initNetCDFOutputFile(SwanTPSDescript,reterr) CALL initNetCDFOutputFile(SwanTPSMaxDescript,reterr) ENDIF IF(SWAN_OutputWIND)THEN CALL initNetCDFOutputFile(SwanWINDDescript,reterr) CALL initNetCDFOutputFile(SwanWINDMaxDescript,reterr) ENDIF IF(SWAN_OutputTM02)THEN CALL initNetCDFOutputFile(SwanTM02Descript,reterr) CALL initNetCDFOutputFile(SwanTM02MaxDescript,reterr) ENDIF IF(SWAN_OutputTMM10)THEN CALL initNetCDFOutputFile(SwanTMM10Descript,reterr) CALL initNetCDFOutputFile(SwanTMM10MaxDescript,reterr) ENDIF ENDIF #endif C IF (C3D.eqv..true.) THEN CALL initNetCDFOutputFile(SigTStaDescript, reterr, & SalStaDescript, TempStaDescript) CALL initNetCDFOutputFile(RealQStaDescript, reterr, & ImaginaryQStaDescript, WZStaDescript) CALL initNetCDFOutputFile(Q20StaDescript, reterr, & LStaDescript, EVStaDescript) CALL initNetCDFOutputFile(SigTDescript, reterr, & SalDescript, TempDescript) CALL initNetCDFOutputFile(RealQDescript, reterr, & ImaginaryQDescript, WZDescript) CALL initNetCDFOutputFile(Q20Descript, reterr, & LDescript, EVDescript) CALL initNetCDFOutputFile(QSurfKp1Descript, reterr) ENDIF C C Create NetCDF hotstart files if NetCDF was specified. IF ((abs(NHSTAR).EQ.3).OR.(NHSTAR.EQ.367).OR.(NHSTAR.EQ.368).OR. & (abs(NHSTAR).EQ.5).OR.(NHSTAR.EQ.567).OR.(NHSTAR.EQ.568)) THEN ! must init both hotstart files ... there is not enough information ! available to determine if they will both be needed IF ((IHOT.ne.367).and.(IHOT.ne.567)) THEN Elev1Descript % file_name = 'fort.67' CALL initNetCDFHotstart(67, Elev1Descript, & Elev2Descript, VelDescript, CH1Descript, EtaDiscDescript, & NodeCodeDescript, NOFFDescript, reterr) IF (C3D.eqv..true.) THEN CALL initNetCDFHotstart3D(67,NHSTAR) ENDIF ENDIF IF ((IHOT.ne.368).and.(IHOT.ne.568)) THEN Elev1Descript % file_name = 'fort.68' CALL initNetCDFHotstart(68, Elev1Descript, & Elev2Descript, VelDescript, CH1Descript, EtaDiscDescript, & NodeCodeDescript, NOFFDescript, reterr) IF (C3D.eqv..true.) THEN CALL initNetCDFHotstart3D(68,NHSTAR) ENDIF ENDIF IF (IHARIND.eq.1) THEN IF ((IHOT.ne.367).and.(IHOT.ne.567)) THEN CALL initNetCDFHotstartHarmonic(67, & HarmElevFDLVDescript, HarmElevSLVDescript, & HarmUVelFDLVDescript, HarmVVelFDLVDescript, & HarmUVelSLVDescript, HarmVVelSLVDescript, reterr) ENDIF IF ((IHOT.ne.368).and.(IHOT.ne.568)) THEN CALL initNetCDFHotstartHarmonic(68, & HarmElevFDLVDescript, HarmElevSLVDescript, & HarmUVelFDLVDescript, HarmVVelFDLVDescript, & HarmUVelSLVDescript, HarmVVelSLVDescript, reterr) ENDIF IF (CHARMV.eqv..true.) THEN IF ((IHOT.ne.367).and.(IHOT.ne.567)) THEN CALL initNetCDFHotstartHarmonicMeansVariances( & 67, ELAVDescript, ELVADescript, & XVELAVDescript, YVELAVDescript, XVELVADescript, & YVELVADescript, reterr) ENDIF IF ((IHOT.ne.368).and.(IHOT.ne.568)) THEN CALL initNetCDFHotstartHarmonicMeansVariances( & 68, ELAVDescript, ELVADescript, & XVELAVDescript, YVELAVDescript, XVELVADescript, & YVELVADescript, reterr) ENDIF ENDIF ENDIF ENDIF ! free up memory allocated for mesh and boundaries CALL freeNetCDFCoord() #endif c---------------------------------------------------------------------------- END SUBROUTINE prepNetCDF c---------------------------------------------------------------------------- C--------------------------------------------------------------------------- C S U B R O U T I N E M A K E F I L E N A M E C--------------------------------------------------------------------------- C jgf51.21.41 A little subroutine to make the file name from the C base name and the file extension. When the write_output module C is integrated into adcprep, this subroutine will be redundant. C--------------------------------------------------------------------------- subroutine makeFileName(descript) use global, only : OutputDataDescript_t implicit none type(OutputDataDescript_t), intent(inout) :: descript character(len=10) :: extString write(extString,'(i0)') descript % file_extension descript % file_name = trim(descript % file_basename) // & '.' // trim(extString) c---------------------------------------------------------------------------- end subroutine makeFileName c----------------------------------------------------------------------------