#include "wwm_functions.h" !********************************************************************** !* * !********************************************************************** SUBROUTINE CF_EXTRACT_TIME(eStrUnitTime, ConvertToDay, eTimeStart) USE DATAPOOL IMPLICIT NONE character(len=100), intent(in) :: eStrUnitTime real(rkind), intent(out) :: ConvertToDay, eTimeStart character (len=100) :: Xname, Yname character (len=10) :: YnameYear, YnameMonth, YnameDay character (len=10) :: YnameHour, YnameMin, YnameSec character (len=50) :: YnameB, YnameD, YnameE character (len=50) :: YnameDate, YnameTime, YnameTimeP character (len=15) :: eStrTime integer alenB, alenC, alenD, alenE, alenTime, alenDate integer alen, posBlank integer lenHour, lenMin, lenSec, lenMonth, lenDay, posSepDateTime alen=LEN_TRIM(eStrUnitTime) posBlank=INDEX(eStrUnitTime(1:alen), ' ') Xname=eStrUnitTime(1:posBlank-1) ! should be days/hours/seconds IF (TRIM(Xname) .eq. 'days') THEN ConvertToDay=1 ELSEIF (TRIM(Xname) .eq. 'hours') THEN ConvertToDay=1/24 ELSEIF (TRIM(Xname) .eq. 'seconds') THEN ConvertToDay=1/86400 ELSE CALL WWM_ABORT('Error in the code for conversion') END IF ! Yname=eStrUnitTime(posBlank+1:alen) alenB=LEN_TRIM(Yname) posBlank=INDEX(Yname(1:alenB), ' ') YnameB=Yname(posBlank+1:alenB) ! should be 1990-01-01 0:0:0 ! alenC=LEN_TRIM(YnameB) posSepDateTime=INDEX(YnameB(1:alenC), ' ') IF (posSepDateTime .gt. 0) THEN YnameDate=YnameB(1:posSepDateTime-1) ! should be 1990-01-01 YnameTimeP=YnameB(posSepDateTime+1:alenC) ! should be 0:0:0 alenC=LEN_TRIM(YnameTimeP) posBlank=INDEX(YnameTimeP(1:alenC), ' ') IF (posBlank .eq. 0) THEN YnameTime=YnameTimeP ELSE YnameTime=YnameTimeP(1:posBlank-1) END IF ELSE YnameDate=YnameB eStrTime(10:10)='0' eStrTime(11:11)='0' eStrTime(12:12)='0' eStrTime(13:13)='0' eStrTime(14:14)='0' eStrTime(15:15)='0' END IF ! alenDate=LEN_TRIM(YnameDate) posBlank=INDEX(YnameDate(1:alenDate), '-') YnameYear=YnameDate(1:posBlank-1) ! should be 1990 YnameD=YnameDate(posBlank+1:alenDate) alenD=LEN_TRIM(YnameD) posBlank=INDEX(YnameD(1:alenD), '-') YnameMonth=YnameD(1:posBlank-1) ! should be 01 YnameDay=YnameD(posBlank+1:alenD) ! should be 01 ! ! year eStrTime( 1: 1)=YnameYear( 1: 1) eStrTime( 2: 2)=YnameYear( 2: 2) eStrTime( 3: 3)=YnameYear( 3: 3) eStrTime( 4: 4)=YnameYear( 4: 4) ! ! month WRITE(WINDBG%FHNDL,*) 'YnameMonth=', YnameMonth lenMonth=LEN_TRIM(YnameMonth) IF (lenMonth .eq. 2) THEN eStrTime( 5: 5)=YnameMonth( 1: 1) eStrTime( 6: 6)=YnameMonth( 2: 2) ELSE IF (lenMonth .eq. 1) THEN eStrTime( 5: 5)='0' eStrTime( 6: 6)=YnameMonth( 1: 1) ELSE CALL WWM_ABORT('DIE in trying to get the month') END IF END IF ! ! day lenDay=LEN_TRIM(YnameDay) IF (lenDay .eq. 2) THEN eStrTime( 7: 7)=YnameDay( 1: 1) eStrTime( 8: 8)=YnameDay( 2: 2) ELSE IF (lenDay .eq. 1) THEN eStrTime( 7: 7)='0' eStrTime( 8: 8)=YnameDay( 1: 1) ELSE CALL WWM_ABORT('DIE in trying to get the day') END IF END IF ! eStrTime( 9: 9)='.' ! IF (posSepDateTime .gt. 0) THEN ! alenTime=LEN_TRIM(YnameTime) posBlank=INDEX(YnameTime(1:alenTime), ':') YnameHour=YnameTime(1:posBlank-1) ! should be 0 YnameE=YnameTime(posBlank+1:alenTime) alenE=LEN_TRIM(YnameE) posBlank=INDEX(YnameE(1:alenE), ':') YnameMin=YnameE(1:posBlank-1) ! should be 0 YnameSec=YnameE(posBlank+1:alenE) ! should be 0 ! ! ! Hour lenHour=LEN_TRIM(YnameHour) IF (lenHour .eq. 2) THEN eStrTime(10:10)=YnameHour( 1: 1) eStrTime(11:11)=YnameHour( 2: 2) ELSE IF (lenHour .eq. 1) THEN eStrTime(10:10)='0' eStrTime(11:11)=YnameHour( 1: 1) ELSE CALL WWM_ABORT('DIE in trying to get the hour') END IF END IF ! ! Min lenMin=LEN_TRIM(YnameMin) IF (lenMin .eq. 2) THEN eStrTime(12:12)=YnameMin( 1: 1) eStrTime(13:13)=YnameMin( 2: 2) ELSE IF (lenMin .eq. 1) THEN eStrTime(12:12)='0' eStrTime(13:13)=YnameMin( 1: 1) ELSE CALL WWM_ABORT('DIE in trying to get the min') END IF END IF ! ! Sec lenSec=LEN_TRIM(YnameSec) IF (lenSec .eq. 2) THEN eStrTime(14:14)=YnameSec( 1: 1) eStrTime(15:15)=YnameSec( 2: 2) ELSE IF (lenSec .eq. 1) THEN eStrTime(14:14)='0' eStrTime(15:15)=YnameSec( 1: 1) ELSE WRITE(WINDBG%FHNDL,*) 'YnameSec=', TRIM(Ynamesec) WRITE(WINDBG%FHNDL,*) 'lenSec=', lenSec FLUSH(WINDBG%FHNDL) CALL WWM_ABORT('DIE in trying to get the sec') END IF END IF END IF WRITE(WINDBG%FHNDL,*) 'eStrTime=', eStrTime CALL CT2MJD(eStrTime, eTimeStart) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE DETERMINE_NEEDED_COMPUTATION(eVar) USE DATAPOOL, only : VAROUT, OUTVARS_COMPLETE implicit none type(VAROUT), intent(inout) :: eVar LOGICAL :: HS, TM01, TM02, TM10, KLM, WLM, & & ETOTC, ETOTS, DM, DSPR, & & TPPD, CPPD, KPPD, CGPD, & & TPP, CPP, WNPP, CGPP, KPP, LPP, PEAKD, PEAKDSPR, & & DPEAK, UBOT, ORBITAL, BOTEXPER, TMBOT, & & URSELL, UFRIC, Z0, ALPHA_CH, WINDX, WINDY, CD, & & CURRTX, CURRTY, WATLEV, WATLEVOLD, DEPDT, DEP, & & WINDMAG, TAUW, TAUWX, TAUWY, TAUHF, TAUTOT, & & STOKESBOTTX, STOKESBOTTY, & & STOKESSURFX, STOKESSURFY, STOKESBAROX, STOKESBAROY, & & RSXX, RSXY, RSYY, CFL1, CFL2, CFL3, ZETA_SETUP LOGICAL :: ComputeMean, ComputeDirSpread, ComputePeak LOGICAL :: ComputeCurr, ComputeUrsell, ComputeStokes integer iVar, idx, nbOutVarEff integer istat HS = eVar%LVAR( 1) TM01 = eVar%LVAR( 2) TM02 = eVar%LVAR( 3) TM10 = eVar%LVAR( 4) KLM = eVar%LVAR( 5) WLM = eVar%LVAR( 6) ETOTC = eVar%LVAR( 7) ETOTS = eVar%LVAR( 8) DM = eVar%LVAR( 9) DSPR = eVar%LVAR(10) TPPD = eVar%LVAR(11) CPPD = eVar%LVAR(12) KPPD = eVar%LVAR(13) CGPD = eVar%LVAR(14) TPP = eVar%LVAR(15) CPP = eVar%LVAR(16) WNPP = eVar%LVAR(17) CGPP = eVar%LVAR(18) KPP = eVar%LVAR(19) LPP = eVar%LVAR(20) PEAKD = eVar%LVAR(21) PEAKDSPR = eVar%LVAR(22) DPEAK = eVar%LVAR(23) UBOT = eVar%LVAR(24) ORBITAL = eVar%LVAR(25) BOTEXPER = eVar%LVAR(26) TMBOT = eVar%LVAR(27) URSELL = eVar%LVAR(28) UFRIC = eVar%LVAR(29) Z0 = eVar%LVAR(30) ALPHA_CH = eVar%LVAR(31) WINDX = eVar%LVAR(32) WINDY = eVar%LVAR(33) CD = eVar%LVAR(34) CURRTX = eVar%LVAR(35) CURRTY = eVar%LVAR(36) WATLEV = eVar%LVAR(37) WATLEVOLD = eVar%LVAR(38) DEPDT = eVar%LVAR(39) DEP = eVar%LVAR(40) WINDMAG = eVar%LVAR(41) TAUW = eVar%LVAR(42) TAUWX = eVar%LVAR(43) TAUWY = eVar%LVAR(44) TAUHF = eVar%LVAR(45) TAUTOT = eVar%LVAR(46) STOKESBOTTX = eVar%LVAR(47) STOKESBOTTY = eVar%LVAR(48) STOKESSURFX = eVar%LVAR(49) STOKESSURFY = eVar%LVAR(50) STOKESBAROX = eVar%LVAR(51) STOKESBAROY = eVar%LVAR(52) RSXX = eVar%LVAR(53) RSXY = eVar%LVAR(54) RSYY = eVar%LVAR(55) CFL1 = eVar%LVAR(56) CFL2 = eVar%LVAR(57) CFL3 = eVar%LVAR(58) ZETA_SETUP = eVar%LVAR(59) ComputeMean=.FALSE. ComputeDirSpread=.FALSE. ComputePeak=.FALSE. ComputeCurr=.FALSE. ComputeUrsell=.FALSE. ComputeStokes=.FALSE. IF (HS .or. TM01 .or. TM02 .or. TM10 .or. KLM .or. WLM) THEN ComputeMean=.TRUE. END IF IF (ETOTC .or. ETOTS .or. DM .or. DSPR) THEN ComputeDirspread=.TRUE. END IF IF (TPPD .or. CPPD .or. KPPD .or. CGPD .or. TPP .or. CPP .or. WNPP .or. CGPP .or. KPP .or. LPP .or. PEAKD .or. PEAKDSPR .or. DPEAK) THEN ComputePeak=.TRUE. END IF IF (UBOT .or. ORBITAL .or. BOTEXPER .or. TMBOT) THEN ComputeCurr=.TRUE. END IF IF (URSELL) THEN ComputeUrsell=.TRUE. ComputeMean=.TRUE. ComputePeak=.TRUE. END IF IF (STOKESSURFX .or. STOKESSURFY .or. STOKESBOTTX .or. STOKESBOTTY .or. STOKESBAROX .or. STOKESBAROY) THEN ComputeStokes=.TRUE. END IF eVar%ComputeMean=ComputeMean eVar%ComputeDirspread=ComputeDirspread eVar%ComputePeak=ComputePeak eVar%ComputeCurr=ComputeCurr eVar%ComputeUrsell=ComputeUrsell eVar%ComputeStokes=ComputeStokes nbOutVarEff=0 DO iVar=1,OUTVARS_COMPLETE IF (eVar%LVAR(iVar)) THEN nbOutVarEff=nbOutVarEff+1 END IF END DO eVar%nbOutVarEff=nbOutVarEff allocate(eVar%ListIdxEff(nbOutVarEff), stat=istat) IF (istat/=0) CALL WWM_ABORT('wwm_netcdf, allocate error 1') idx=0 DO iVar=1,OUTVARS_COMPLETE IF (eVar%LVAR(iVar)) THEN idx=idx+1 eVar%ListIdxEff(idx)=iVar END IF END DO END SUBROUTINE #ifdef NCDF !********************************************************************** !* * !********************************************************************** SUBROUTINE SERIAL_GET_BOUNDARY_NEXTGENERATION(TheBound) USE DATAPOOL IMPLICIT NONE type(BoundaryInfo), intent(inout) :: TheBound integer :: ContElements(np_total) integer :: ListDegWork(np_total) integer, allocatable :: ListAdjWithDupl(:,:) integer, allocatable :: IEcontain(:,:) integer, allocatable :: StatusAdj(:) integer IE, I, IP, INEXT, IPREV, IPadj integer IP_N, IP_P, eDeg, nb1, nb2, nb, J integer NumberAllTwo, NumberBoundary, NumberPathological integer SatMaxDeg, pos, MaxIEcont, eDegVert integer IsPointClassicalBoundary(np_total) integer IsPointPathologicalBoundary(np_total) integer NumberContainedEdges(np_total) integer ListDegVertBound(np_total) integer,allocatable :: ListDegEdgeBound(:) integer idxEdgeBound, idx integer iEdgeBound, MaxNbContEdge integer, allocatable :: MappingIP_iEdgeBound(:,:) integer jEdgeBound, eRealDeg, eRealDegBound integer, allocatable :: ListAdjVert(:), ListAdjVertBound(:), ListMatchVert(:) integer idxDeg, idxDegBound, nbContIE, idxIE, jVertBound real(rkind), allocatable :: ListAng(:) logical WeDoOperation, WeWork integer iVertBound, IP1, IP_C real(rkind) DeltaX, DeltaY, eAng, eAngLargest, eAngSmallest, eDiffAng integer idxLargest, idxSmallest, iEdgeBoundFound, IPwork1, IPwork2 integer, allocatable :: ListPrevVertBound(:), ListNextVertBound(:) integer eDegEdgeBound, iEdge, jVertBoundFound, NbCycle integer iEdgeBoundFirst, iEdgeBoundWork, IPfound, len integer IP_prev, IP_next, IP2 integer, allocatable :: ListIedgeBound(:), LenCycle(:) integer iEdgeBoundNext ContElements=0 DO IE=1,NE_TOTAL DO I=1,3 IP=INEtotal(I,IE) ContElements(IP)=ContElements(IP)+1 END DO END DO MaxIEcont=maxval(ContElements) SatMaxDeg=2*MaxIEcont allocate(ListAdjWithDupl(SatMaxDeg,NP_TOTAL)) allocate(IEcontain(MaxIEcont,NP_TOTAL)) ListDegWork=0 DO IE=1,NE_TOTAL DO I=1,3 IF (I.eq.3) THEN INEXT=1 ELSE INEXT=I+1 END IF IF (I.eq.1) THEN IPREV=3 ELSE IPREV=I-1 END IF IP=INEtotal(I,IE) IP_N=INEtotal(INEXT,IE) IP_P=INEtotal(IPREV,IE) pos=ListDegWork(IP) ListAdjWithDupl(2*pos+1,IP)=IP_N ListAdjWithDupl(2*pos+2,IP)=IP_P IF ((IP.eq.IP_N).or.(IP.eq.IP_P)) THEN WRITE(DBG%FHNDL,*) 'IE=', IE WRITE(DBG%FHNDL,*) 'I=', I, 'IP=', IP WRITE(DBG%FHNDL,*) 'INEXT=', INEXT, ' IP_N=', IP_N WRITE(DBG%FHNDL,*) 'IPREV=', IPREV, ' IP_P=', IP_P CALL WWM_ABORT("logical error") END IF IEcontain(pos+1,IP)=IE ListDegWork(IP)=pos+1 END DO END DO WRITE(STAT%FHNDL,*) 'Stage 1 finished' FLUSH(STAT%FHNDL) allocate(StatusAdj(SatMaxDeg)) allocate(TheBound % IOBP(np_total)) NumberAllTwo=0 NumberBoundary=0 NumberPathological=0 TheBound % nbEdgeBound=0 TheBound % nbVertBound=0 IsPointClassicalBoundary=0 IsPointPathologicalBoundary=0 DO IP=1,NP_TOTAL eDeg=ListDegWork(IP) StatusAdj=0 nb1=0 nb2=0 eDegVert=2*eDeg DO I=1,eDegVert IF (StatusAdj(I) .eq. 0) THEN IPadj=ListAdjWithDupl(I,IP) nb=0 DO J=I,eDegVert IF (ListAdjWithDupl(J,IP) .eq. IPadj) THEN nb=nb+1 StatusAdj(J)=1 END IF END DO IF (nb .eq. 0) CALL WWM_ABORT("Clear bug in code") IF (nb .gt. 2) THEN WRITE(DBG%FHNDL,*) 'IP=', IP, 'IPadj=', IPadj DO J=1,eDeg IE=IEcontain(J,IP) WRITE(DBG%FHNDL,*) 'IE=', IE WRITE(DBG%FHNDL,*) 'INE=', INEtotal(1,IE), INEtotal(2,IE), INEtotal(3,IE) END DO CALL WWM_ABORT("Hopelessly pathological grid") END IF IF (nb .eq. 1) nb1=nb1+1 IF (nb .eq. 2) nb2=nb2+1 IF ((nb .eq. 1).and.(IP .gt. IPadj)) TheBound % nbEdgeBound = TheBound % nbEdgeBound + 1 END IF END DO IF (nb1 .eq. 0) NumberAllTwo=NumberAllTwo + 1 IF (nb1 .eq. 1) CALL WWM_ABORT("Number 1 should not happen") IF (nb1 .eq. 2) THEN NumberBoundary=NumberBoundary + 1 IsPointClassicalBoundary(IP)=1 END IF IF (nb1 .gt. 2) THEN NumberPathological=NumberPathological + 1 IsPointPathologicalBoundary(IP)=1 END IF IF (nb1 .gt. 0) THEN TheBound % IOBP(IP)=1 TheBound % nbVertBound=TheBound % nbVertBound+1 END IF END DO WRITE(STAT%FHNDL,*) 'NumberAllTwo =', NumberAllTwo WRITE(STAT%FHNDL,*) 'NumberBoundary =', NumberBoundary WRITE(STAT%FHNDL,*) 'NumberPathological=', NumberPathological FLUSH(STAT%FHNDL) WRITE(STAT%FHNDL,*) 'Stage 2 finished' FLUSH(STAT%FHNDL) allocate(TheBound % ListBoundEdge(2, TheBound % nbEdgeBound)) idxEdgeBound=0 TheBound % IOBP = 0 DO IP=1,NP_TOTAL eDeg=ListDegWork(IP) StatusAdj=0 eDegVert=2*eDeg DO I=1,eDegVert IF (StatusAdj(I) .eq. 0) THEN IPadj=ListAdjWithDupl(I,IP) nb=0 DO J=I,eDegVert IF (ListAdjWithDupl(J,IP) .eq. IPadj) THEN nb=nb+1 StatusAdj(J)=1 END IF END DO IF ((nb .eq. 1).and.(IP .gt. IPadj)) THEN idxEdgeBound=idxEdgeBound+1 TheBound % ListBoundEdge(1,idxEdgeBound)=IPadj TheBound % ListBoundEdge(2,idxEdgeBound)=IP END IF END IF END DO END DO WRITE(STAT%FHNDL,*) 'Stage 3 finished' FLUSH(STAT%FHNDL) allocate(TheBound % ListVertBound(TheBound % nbVertBound)) idx=0 DO IP=1,np_total IF (TheBound % IOBP(IP) .eq. 1) THEN idx=idx+1 TheBound % ListVertBound(idx)=IP END IF END DO NumberContainedEdges=0 ! Print *, ' maxval(NumberContainedEdges)=', maxval(NumberContainedEdges) DO iEdgeBound=1,TheBound % nbEdgeBound DO I=1,2 IP=TheBound % ListBoundEdge(I,iEdgeBound) NumberContainedEdges(IP)=NumberContainedEdges(IP)+1 END DO ! Print *, 'iEdgeBound=', iEdgeBound, ' max=', maxval(NumberContainedEdges) END DO MaxNbContEdge=maxval(NumberContainedEdges) ListDegVertBound=0 ! Print *, 'nbEdgeBound=', TheBound % nbEdgeBound ! Print *, 'MaxNbContEdge=', MaxNbContEdge, ' np_total=', np_total allocate(MappingIP_iEdgeBound(MaxNbContEdge,np_total)) DO iEdgeBound=1,TheBound % nbEdgeBound DO I=1,2 IP=TheBound % ListBoundEdge(I,iEdgeBound) eDeg=ListDegVertBound(IP) MappingIP_iEdgeBound(eDeg+1,IP)=iEdgeBound ListDegVertBound(IP)=eDeg+1 END DO END DO WRITE(STAT%FHNDL,*) 'Stage 4 finished' FLUSH(STAT%FHNDL) allocate(TheBound % AdjacencyEdgeBound(2,TheBound % nbEdgeBound)) allocate(ListDegEdgeBound(TheBound % nbEdgeBound)) ListDegEdgeBound=0 DO IP=1,np_total IF (IsPointClassicalBoundary(IP) .eq. 1) THEN iEdgeBound=MappingIP_iEdgeBound(1,IP) jEdgeBound=MappingIP_iEdgeBound(2,IP) ! eDeg=ListDegEdgeBound(iEdgeBound) TheBound % AdjacencyEdgeBound(eDeg+1,iEdgeBound)=jEdgeBound ListDegEdgeBound(iEdgeBound)=eDeg+1 ! eDeg=ListDegEdgeBound(jEdgeBound) TheBound % AdjacencyEdgeBound(eDeg+1,jEdgeBound)=iEdgeBound ListDegEdgeBound(jEdgeBound)=eDeg+1 END IF END DO DO IP=1,np_total IF (IsPointPathologicalBoundary(IP) .eq. 1) THEN eDeg=ListDegWork(IP) eDegVert=2*eDeg StatusAdj=0 eRealDeg=0 eRealDegBound=0 DO I=1,eDegVert IF (StatusAdj(I) .eq. 0) THEN IPadj=ListAdjWithDupl(I,IP) nb=0 DO J=I,eDegVert IF (ListAdjWithDupl(J,IP) .eq. IPadj) THEN nb=nb+1 StatusAdj(J)=1 END IF END DO eRealDeg=eRealDeg+1 IF (nb .eq. 1) eRealDegBound=eRealDegBound+1 END IF END DO allocate(ListAdjVert(eRealDeg)) allocate(ListAdjVertBound(eRealDegBound)) StatusAdj=0 idxDeg=0 idxDegBound=0 DO I=1,eDegVert IF (StatusAdj(I) .eq. 0) THEN IPadj=ListAdjWithDupl(I,IP) IF (IPadj .eq. 0) CALL WWM_ABORT("IPadj should be non-zero") nb=0 DO J=I,eDegVert IF (ListAdjWithDupl(J,IP) .eq. IPadj) THEN nb=nb+1 StatusAdj(J)=1 END IF END DO idxDeg=idxDeg+1 ListAdjVert(idxDeg)=IPadj IF (nb .eq. 1) THEN idxDegBound=idxDegBound+1 ListAdjVertBound(idxDegBound)=IPadj END IF END IF END DO if (idxDegBound .ne. eRealDegBound) CALL WWM_ABORT("Logical error on eRealDegBound") nbContIE=ListDegWork(IP) allocate(ListMatchVert(eRealDegBound)) ListMatchVert=ListAdjVertBound DO WeDoOperation=.false. DO iVertBound=1,eRealDegBound IP1=ListMatchVert(iVertBound) DO idxIE=1,nbContIE IE=IEcontain(idxIE,IP) DO I=1,3 IF (I.eq.3) THEN INEXT=1 ELSE INEXT=I+1 END IF IF (I.eq.1) THEN IPREV=3 ELSE IPREV=I-1 END IF IP_C=INEtotal(I,IE) IP_N=INEtotal(INEXT,IE) IP_P=INEtotal(IPREV,IE) IF ((IP_C.eq.IP).and.(IP_N.eq.IP1)) THEN WeDoOperation=.true. ListMatchVert(iVertBound)=IP_P END IF END DO END DO END DO IF (WeDoOperation .eqv. .false.) THEN EXIT END IF END DO allocate(ListAng(eRealDegBound)) DO iVertBound=1,eRealDegBound IPadj=ListAdjVertBound(iVertBound) DeltaX=XPtotal(IPadj) - XPtotal(IP) DeltaY=YPtotal(IPadj) - YPtotal(IP) eAng=ATAN2(DeltaY, DeltaX) ListAng(iVertBound)=eAng END DO allocate(ListPrevVertBound(eRealDegBound), ListNextVertBound(eRealDegBound)) ! Print *, 'Before determination of next/prev s' DO iVertBound=1,eRealDegBound ! Print *, 'iVertBound=', iVertBound idxLargest=0 idxSmallest=0 eAngLargest=-1.0 eAngSmallest=400.0 DO jVertBound=1,eRealDegBound IF (jVertBound .ne. iVertBound) THEN eDiffAng=ListAng(jVertBound) - ListAng(iVertBound) if (eDiffAng .lt. 0) eDiffAng = eDiffAng + PI2 IF (eDiffAng .gt. eAngLargest) THEN eAngLargest=eDiffAng idxLargest=jVertBound END IF IF (eDiffAng .lt. eAngSmallest) THEN eAngSmallest=eDiffAng idxSmallest=jVertBound END IF END IF END DO ListPrevVertBound(iVertBound)=ListAdjVertBound(idxSmallest) ListNextVertBound(iVertBound)=ListAdjVertBound(idxLargest) ! Print *, 'IP=', ListAdjVertBound(iVertBound), ' match=', ListMatchVert(iVertBound) ! Print *, 'iV=', iVertBound, ' prev/next=', ListPrevVertBound(iVertBound), ListNextVertBound(iVertBound) END DO deallocate(ListAng) allocate(ListIedgeBound(eRealDegBound)) DO iVertBound=1,eRealDegBound IP1=ListAdjVertBound(iVertBound) IF (IP .lt. IP1) THEN IPwork1=IP IPwork2=IP1 ELSE IPwork1=IP1 IPwork2=IP END IF iEdgeBoundFound=-1 eDegEdgeBound=ListDegVertBound(IP) DO iEdge=1,eDegEdgeBound iEdgeBound=MappingIP_iEdgeBound(iEdge,IP) IF ((TheBound % ListBoundEdge(1,iEdgeBound) .eq. IPwork1).and.(TheBound % ListBoundEdge(2,iEdgeBound).eq.IPwork2)) THEN iEdgeBoundFound=iEdgeBound END IF END DO IF (iEdgeBoundFound .eq. -1) CALL WWM_ABORT("Error in finding iEdgeBoundFound") ListIedgeBound(iVertBound)=iEdgeBoundFound END DO ! Print *, 'eRealDegBound=', eRealDegBound DO iVertBound=1,eRealDegBound IP1=ListAdjVertBound(iVertBound) IP2=ListMatchVert(iVertBound) IF (IP1 .ne. IP2) THEN IP_prev=ListPrevVertBound(iVertBound) IP_next=ListNextVertBound(iVertBound) IPadj=0 IF (IP2 .eq. IP_prev) IPadj=IP_next IF (IP2 .eq. IP_next) IPadj=IP_prev IF (IPadj .eq. 0) CALL WWM_ABORT("Clear bug to solve") jVertBoundFound=-1 DO jVertBound=1,eRealDegBound IF (ListAdjVertBound(jVertBound) .eq. IPadj) jVertBoundFound=jVertBound END DO IF (jVertBoundFound .eq. -1) CALL WWM_ABORT("Another error") jVertBound=jVertBoundFound iEdgeBound=ListIedgeBound(iVertBound) jEdgeBound=ListIedgeBound(jVertBound) ! eDeg=ListDegEdgeBound(iEdgeBound) TheBound % AdjacencyEdgeBound(eDeg+1,iEdgeBound)=jEdgeBound ListDegEdgeBound(iEdgeBound)=eDeg+1 ! eDeg=ListDegEdgeBound(jEdgeBound) TheBound % AdjacencyEdgeBound(eDeg+1,jEdgeBound)=iEdgeBound ListDegEdgeBound(jEdgeBound)=eDeg+1 END IF END DO deallocate(ListIedgeBound) deallocate(ListMatchVert) deallocate(ListPrevVertBound, ListNextVertBound) deallocate(ListAdjVert, ListAdjVertBound) END IF END DO WRITE(STAT%FHNDL,*) 'Stage 5 finished' FLUSH(STAT%FHNDL) DO iEdgeBound=1,TheBound % nbEdgeBound WRITE(DBG%FHNDL,*) 'iEdgeBound/eDeg=', iEdgeBound, ListDegEdgeBound(iEdgeBound) END DO DO iEdgeBound=1,TheBound % nbEdgeBound IF (ListDegEdgeBound(iEdgeBound) .ne. 2) THEN WRITE(DBG%FHNDL,*) 'iEdgeBound=', iEdgeBound WRITE(DBG%FHNDL,*) 'eDeg=', ListDegEdgeBound(iEdgeBound) CALL WWM_ABORT("Degree error") END IF END DO allocate(TheBound % NEIGHBORedge(TheBound % nbEdgeBound)) allocate(TheBound % CorrespVertex(TheBound % nbEdgeBound)) TheBound % NEIGHBORedge=0 allocate(LenCycle(TheBound % nbEdgeBound)) allocate(TheBound % TheCycleBelong(TheBound % nbEdgeBound)) LenCycle=0 NbCycle=0 DO iEdgeBound=1,TheBound % nbEdgeBound IF (TheBound % NEIGHBORedge(iEdgeBound) .eq. 0) THEN NbCycle = NbCycle + 1 iEdgeBoundFirst=iEdgeBound iEdgeBoundWork=iEdgeBound iEdgeBoundNext=TheBound % AdjacencyEdgeBound(1,iEdgeBound) len=0 DO TheBound % NEIGHBORedge(iEdgeBoundWork)=iEdgeBoundNext IPfound=-1 DO I=1,2 IP=TheBound % ListBoundEdge(I,iEdgeBoundWork) DO J=1,2 IP2=TheBound % ListBoundEdge(J,iEdgeBoundNext) IF (IP2 .eq. IP) THEN IPfound=IP END IF END DO END DO IF (IPfound .eq. -1) CALL WWM_ABORT("Error in looking for IPfound") TheBound % CorrespVertex(iEdgeBoundWork)=IPfound TheBound % TheCycleBelong(iEdgeBoundWork)=NbCycle len=len+1 WeWork=.false. DO I=1,2 IF (Wework .eqv. .false.) THEN jEdgeBound=TheBound % AdjacencyEdgeBound(I,iEdgeBoundNext) IF (jEdgeBound .ne. iEdgeBoundWork) THEN WeWork=.true. iEdgeBoundWork=iEdgeBoundNext iEdgeBoundNext=jEdgeBound END IF END IF END DO if (iEdgeBoundNext .eq. iEdgeBoundFirst) EXIT END DO LenCycle(NbCycle)=len END IF END DO TheBound % NbCycle=NbCycle allocate(TheBound % LenCycle(NbCycle)) DO i=1,NbCycle TheBound % LenCycle(i)=LenCycle(i) END DO deallocate(StatusAdj, ListAdjWithDupl) deallocate(MappingIP_iEdgeBound, ListDegEdgeBound) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE DeallocateBoundaryInfo(TheBound) USE DATAPOOL IMPLICIT NONE type(BoundaryInfo), intent(inout) :: TheBound deallocate(TheBound % ListVertBound) deallocate(TheBound % ListBoundEdge) deallocate(TheBound % AdjacencyEdgeBound) deallocate(TheBound % NEIGHBORedge) deallocate(TheBound % CorrespVertex) deallocate(TheBound % TheCycleBelong) deallocate(TheBound % LenCycle) deallocate(TheBound % IOBP) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE SERIAL_WRITE_BOUNDARY(ncid, np_glob, ne_glob, INEglob, Oper) USE NETCDF USE DATAPOOL implicit none integer, intent(in) :: ncid, Oper integer, intent(in) :: np_glob, ne_glob integer, intent(in) :: INEglob(ne_glob,3) integer iret, var_id, two_dims integer nbVertBound_dims, nbEdgeBound_dims, NbCycle_dims integer idx character (len = *), parameter :: CallFct="SERIAL_WRITE_BOUNDARY" character (len = *), parameter :: FULLNAME = "full-name" type(BoundaryInfo) TheBound ! Print *, 'Entering SERIAL_WRITE_BOUNDARY' CALL SERIAL_GET_BOUNDARY_NEXTGENERATION(TheBound) ! Print *, 'After SERIAL_GET_BOUNDARY_NEXTGEN, Oper=', Oper IF ((Oper == 1).and.(TheBound % nbEdgeBound.gt.0)) THEN iret=nf90_inq_dimid(ncid, 'two', two_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) ! iret = nf90_def_dim(ncid, 'nbEdgeBound', TheBound % nbEdgeBound, nbEdgeBound_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) iret = nf90_def_dim(ncid, 'nbVertBound', TheBound % nbVertBound, nbVertBound_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret = nf90_def_dim(ncid, 'NbCycle', TheBound % NbCycle, NbCycle_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) ! iret=nf90_def_var(ncid,'ListVertBound',NF90_INT,(/ nbVertBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'IP of boundary element') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) ! iret=nf90_def_var(ncid,'ListBoundEdge',NF90_INT,(/ two_dims, nbEdgeBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'boundary edges') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) ! iret=nf90_def_var(ncid,'AdjacencyEdgeBound',NF90_INT,(/ two_dims, nbEdgeBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'boundary edges') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) ! iret=nf90_def_var(ncid,'NEIGHBORedge',NF90_INT,(/ nbEdgeBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'next boundary edge in the cycle') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) ! iret=nf90_def_var(ncid,'CorrespVertex',NF90_INT,(/ nbEdgeBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'Corresponding vertex to the boundary edge') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) ! iret=nf90_def_var(ncid,'CycleBelong',NF90_INT,(/ nbEdgeBound_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'The cycle to which the boundary edge belongs') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) ! iret=nf90_def_var(ncid,'LenCycle',NF90_INT,(/ NbCycle_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'Length of cycles') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 18, iret) END IF ! Print *, 'After Oper=1' ! Print *, 'TheBound % nbEdgeBound=', TheBound % nbEdgeBound IF ((Oper == 2).and.(TheBound % nbEdgeBound.gt.0)) THEN iret=nf90_inq_varid(ncid, "ListVertBound", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 19, iret) iret=nf90_put_var(ncid,var_id,TheBound % ListVertBound, start = (/1/), count = (/ TheBound % nbVertBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 20, iret) ! iret=nf90_inq_varid(ncid, "ListBoundEdge", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 21, iret) iret=nf90_put_var(ncid,var_id,TheBound % ListBoundEdge, start = (/1, 1/), count = (/ 2, TheBound % nbEdgeBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 22, iret) ! iret=nf90_inq_varid(ncid, "AdjacencyEdgeBound", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 23, iret) iret=nf90_put_var(ncid,var_id,TheBound % AdjacencyEdgeBound, start = (/1, 1/), count = (/ 2, TheBound % nbEdgeBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 24, iret) ! iret=nf90_inq_varid(ncid, "NEIGHBORedge", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 25, iret) iret=nf90_put_var(ncid,var_id,TheBound % NEIGHBORedge, start = (/1/), count = (/ TheBound % nbEdgeBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 26, iret) ! iret=nf90_inq_varid(ncid, "CorrespVertex", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 27, iret) iret=nf90_put_var(ncid,var_id,TheBound % CorrespVertex, start = (/1/), count = (/ TheBound % nbEdgeBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 28, iret) ! iret=nf90_inq_varid(ncid, "CycleBelong", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 29, iret) iret=nf90_put_var(ncid,var_id,TheBound % TheCycleBelong, start = (/1/), count = (/ TheBound % nbEdgeBound/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 30, iret) ! iret=nf90_inq_varid(ncid, "LenCycle", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 31, iret) iret=nf90_put_var(ncid,var_id,TheBound % LenCycle, start = (/1/), count = (/ TheBound % NbCycle/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 32, iret) END IF ! Print *, 'After Oper=2' CALL DeallocateBoundaryInfo(TheBound) ! Print *, 'After deallocate' END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE REPORT_ERROR_INQ(iret, str) INTEGER, intent(in) :: iret character(*) :: str character(256) :: ErrMsg IF (iret.ne.0) THEN WRITE (ErrMsg,10) 'ERROR while inquiring', str 10 FORMAT (a,' ',a) CALL WWM_ABORT(TRIM(ErrMsg)) ENDIF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE REPORT_ERROR_DEF(iret, str) INTEGER, intent(in) :: iret character(*) :: str character(256) :: ErrMsg IF (iret.ne.0) THEN WRITE (ErrMsg,10) 'ERROR while defining', str 10 FORMAT (a,' ',a) CALL WWM_ABORT(TRIM(ErrMsg)) ENDIF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE GENERIC_NETCDF_ERROR_WWM_CLEAR(ncid, CallFct, idx, iret) USE NETCDF USE DATAPOOL, only : wwmerr implicit none integer, intent(in) :: iret, idx, ncid character(*), intent(in) :: CallFct character(len=500) :: CHRERR integer iretB IF (iret .NE. nf90_noerr) THEN CHRERR = nf90_strerror(iret) WRITE(wwmerr,*) TRIM(CallFct), ' -', idx, '-', CHRERR iretB=nf90_close(ncid) Print *, 'iretB=', iretB CALL WWM_ABORT(wwmerr) ENDIF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE GENERIC_NETCDF_ERROR_WWM(CallFct, idx, iret) USE NETCDF USE DATAPOOL, only : wwmerr implicit none integer, intent(in) :: iret, idx character(*), intent(in) :: CallFct character(len=500) :: CHRERR IF (iret .NE. nf90_noerr) THEN CHRERR = nf90_strerror(iret) WRITE(wwmerr,*) 'NETCDF error in routine ', TRIM(CallFct), ' Error Message: ', TRIM(CHRERR), ' Position in the routine :', idx CALL WWM_ABORT(wwmerr) ENDIF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE NAMEVARIABLE(idx, eStr, eStrFullName, eStrUnit) INTEGER, intent(in) :: idx character(len=40), intent(out) :: eStr character(len=80), intent(out) :: eStrFullName character(len=40), intent(out) :: eStrUnit IF (IDX.eq.1) THEN eStr="HS" eStrFullName="Significant wave height" eStrUnit="meter" ELSE IF (IDX.eq.2) THEN eStr="TM01" eStrFullName="mean wave period" eStrUnit="second" ELSE IF (IDX.eq.3) THEN eStr="TM02" eStrFullName="Zero-crossing wave period" eStrUnit="second" ELSE IF (IDX.eq.4) THEN eStr="TM10" eStrFullName="Mean period of wave over topping/run-up" eStrUnit="second" ELSE IF (IDX.eq.5) THEN eStr="KLM" eStrFullName="mean wave number" eStrUnit="meter-1" ELSE IF (IDX.eq.6) THEN eStr="WLM" eStrFullName="Mean wave length" eStrUnit="meter" ELSE IF (IDX.eq.7) THEN eStr="ETOTC" eStrFullName="model variable" eStrUnit="unk" ELSE IF (IDX.eq.8) THEN eStr="ETOTS" eStrFullName="model variable" eStrUnit="unk" ELSE IF (IDX.eq.9) THEN eStr="DM" eStrFullName="Mean wave direction" eStrUnit="degree" ELSE IF (IDX.eq.10) THEN eStr="DSPR" eStrFullName="Directional spreading" eStrUnit="degree" ELSE IF (IDX.eq.11) THEN eStr="TPPD" eStrFullName="Discrete peak wave period" eStrUnit="second" ELSE IF (IDX.eq.12) THEN eStr="CPPD" eStrFullName="Discrete peak wave speed" eStrUnit="meter second -1" ELSE IF (IDX.eq.13) THEN eStr="KPPD" eStrFullName="discrete peak wave number" eStrUnit="meter-1" ELSE IF (IDX.eq.14) THEN eStr="CGPD" eStrFullName="discrete peak group speed" eStrUnit="meter second-1" ELSE IF (IDX.eq.15) THEN eStr="TPP" eStrFullName="peak wave period" eStrUnit="second" ELSE IF (IDX.eq.16) THEN eStr="CPP" eStrFullName="peak wave speed" eStrUnit="meter second-1" ELSE IF (IDX.eq.17) THEN eStr="WNPP" eStrFullName="unk" eStrUnit="unk" ELSE IF (IDX.eq.18) THEN eStr="CGPP" eStrFullName="peak group velocity" eStrUnit="meter second-1" ELSE IF (IDX.eq.19) THEN eStr="KPP" eStrFullName="peak wave number" eStrUnit="meter-1" ELSE IF (IDX.eq.20) THEN eStr="LPP" eStrFullName="Peak wave length" eStrUnit="meter" ELSE IF (IDX.eq.21) THEN eStr="PEAKD" eStrFullName="Peak wave direction" eStrUnit="degree" ELSE IF (IDX.eq.22) THEN eStr="PEAKDSPR" eStrFullName="Peak directional spreading" eStrUnit="degree" ELSE IF (IDX.eq.23) THEN eStr="DPEAK" eStrFullName="discrete peak direction" eStrUnit="degree" ELSE IF (IDX.eq.24) THEN eStr="UBOT" eStrFullName="wind-induced bottom orbital velocity" eStrUnit="meter second-1" ELSE IF (IDX.eq.25) THEN eStr="ORBITAL" eStrFullName="unk" eStrUnit="unk" ELSE IF (IDX.eq.26) THEN eStr="BOTEXPER" eStrFullName="unk" eStrUnit="unk" ELSE IF (IDX.eq.27) THEN eStr="TMBOT" eStrFullName="unk" eStrUnit="unk" ELSE IF (IDX.eq.28) THEN eStr="URSELL" eStrFullName="ursell number" eStrUnit="non-dimensional" ELSE IF (IDX.eq.29) THEN eStr="UFRIC" eStrFullName="air friction velocity" eStrUnit="meter second-1" ELSE IF (IDX.eq.30) THEN eStr="Z0" eStrFullName="air roughness length" eStrUnit="meter" ELSE IF (IDX.eq.31) THEN eStr="ALPHA_CH" eStrFullName="air Charnock coefficient" eStrUnit="non-dimensional" ELSE IF (IDX.eq.32) THEN eStr="Uwind" eStrFullName="wind in X direction" eStrUnit="meter second-1" ELSE IF (IDX.eq.33) THEN eStr="Vwind" eStrFullName="wind in Y direction" eStrUnit="meter second-1" ELSE IF (IDX.eq.34) THEN eStr="CD" eStrFullName="drag coefficient" eStrUnit="non-dimensional" ELSE IF (IDX.eq.35) THEN eStr="CURTX" eStrFullName="current in X direction" eStrUnit="meter second-1" ELSE IF (IDX.eq.36) THEN eStr="CURTY" eStrFullName="current in Y direction" eStrUnit="meter second-1" ELSE IF (IDX.eq.37) THEN eStr="WATLEV" eStrFullName="water level" eStrUnit="meter" ELSE IF (IDX.eq.38) THEN eStr="WATLEVOLD" eStrFullName="water level at previous time step" eStrUnit="meter" ELSE IF (IDX.eq.39) THEN eStr="DEPDT" eStrFullName="water level change" eStrUnit="meter second-1" ELSE IF (IDX.eq.40) THEN eStr="DEP" eStrFullName="bathymetry" eStrUnit="meter" ELSE IF (IDX.eq.41) THEN eStr="WINDMAG" eStrFullName="10-m wind magnitude" eStrUnit="meter second-1" ELSE IF (IDX.eq.42) THEN eStr="TAUW" eStrFullName="wave supported surface stress" eStrUnit="unk" ELSE IF (IDX.eq.43) THEN eStr="TAUWX" eStrFullName="wave supported surface X-stress" eStrUnit="unk" ELSE IF (IDX.eq.44) THEN eStr="TAUWY" eStrFullName="wave supported surface Y-stress" eStrUnit="unk" ELSE IF (IDX.eq.45) THEN eStr="TAUHF" eStrFullName="high frequency surface stress" eStrUnit="unk" ELSE IF (IDX.eq.46) THEN eStr="TAUTOT" eStrFullName="total surface stress" eStrUnit="unk" ELSE IF (IDX.eq.47) THEN eStr="STOKESBOTTX" eStrFullName="bottom Stokes velocity in X direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.48) THEN eStr="STOKESBOTTY" eStrFullName="bottom Stokes velocity in Y direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.49) THEN eStr="STOKESSURFX" eStrFullName="surface Stokes velocity in X direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.50) THEN eStr="STOKESSURFY" eStrFullName="surface Stokes velocity in Y direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.51) THEN eStr="STOKESBAROX" eStrFullName="barotropic Stokes velocity in X direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.52) THEN eStr="STOKESBAROY" eStrFullName="barotropic Stokes velocity in Y direction" eStrUnit="meter second -1" ELSE IF (IDX.eq.53) THEN eStr="RSXX" eStrFullName="barotropic Stress potential Sxx" eStrUnit="meter2 second2" ELSE IF (IDX.eq.54) THEN eStr="RSXY" eStrFullName="barotropic Stress potential Sxy" eStrUnit="meter2 second2" ELSE IF (IDX.eq.55) THEN eStr="RSYY" eStrFullName="barotropic Stress potential Syy" eStrUnit="meter2 second2" ELSE IF (IDX.eq.56) THEN eStr="CFL1" eStrFullName="CFL number 1" eStrUnit="non-dimensional" ELSE IF (IDX.eq.57) THEN eStr="CFL2" eStrFullName="CFL number 2" eStrUnit="non-dimensional" ELSE IF (IDX.eq.58) THEN eStr="CFL3" eStrFullName="CFL number 3" eStrUnit="non-dimensional" ELSE IF (IDX.eq.59) THEN eStr="ZETA_SETUP" eStrFullName="Free-surface elevation induced setup" eStrUnit="m" ELSE CALL WWM_ABORT('Wrong Number') END IF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_TIME_HEADER(ncid, nbTime, ntime_dims) USE DATAPOOL USE NETCDF IMPLICIT NONE integer, intent(in) :: ncid, nbTime integer, intent(inout) :: ntime_dims character (len = *), parameter :: UNITS = "units" character (len = *), parameter :: CallFct="WRITE_NETCDF_TIME_HEADER" integer iret, fifteen_dims, var_id iret=nf90_inq_dimid(ncid, 'fifteen', fifteen_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) IF (nbTime.gt.0) THEN iret = nf90_def_dim(ncid, 'ocean_time', nbTime, ntime_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) ELSE iret = nf90_def_dim(ncid, 'ocean_time', NF90_UNLIMITED, ntime_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) END IF iret=nf90_def_var(ncid,'ocean_time',NF90_RUNTYPE,(/ ntime_dims/), var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) iret=nf90_put_att(ncid,var_id,UNITS,'seconds since 1858-11-17 00:00:00') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret=nf90_put_att(ncid,var_id,"calendar",'gregorian') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) ! iret=nf90_def_var(ncid,'ocean_time_day',NF90_RUNTYPE,(/ ntime_dims/), var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) iret=nf90_put_att(ncid,var_id,UNITS,'days since 1858-11-17 00:00:00') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) iret=nf90_put_att(ncid,var_id,"calendar",'gregorian') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) ! iret=nf90_def_var(ncid,'ocean_time_str',NF90_CHAR,(/ fifteen_dims, ntime_dims/), var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_TIME(ncid, idx, eTimeDay) USE DATAPOOL, only : DAY2SEC,RKIND, wwmerr USE NETCDF IMPLICIT NONE integer, intent(in) :: ncid, idx REAL(rkind), intent(IN) :: eTimeDay character (len = *), parameter :: CallFct="WRITE_NETCDF_TIME" integer oceantimeday_id, oceantimestr_id, oceantime_id integer iret, I CHARACTER :: eChar REAL(rkind) eTimeSec CHARACTER(LEN=15) :: eTimeStr ! CALL MJD2CT(eTimeDay,eTimeStr) eTimeSec=eTimeDay*DAY2SEC iret=nf90_inq_varid(ncid, 'ocean_time', oceantime_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) iret=nf90_put_var(ncid,oceantime_id,eTimeSec,start=(/idx/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) ! iret=nf90_inq_varid(ncid, 'ocean_time_day', oceantimeday_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret=nf90_put_var(ncid,oceantimeday_id,eTimeDay,start=(/idx/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) ! iret=nf90_inq_varid(ncid, 'ocean_time_str', oceantimestr_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) DO i=1,15 eChar=eTimeStr(i:i) iret=nf90_put_var(ncid,oceantimestr_id,eChar,start=(/i, idx/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) END DO END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE GET_IOBPD_OUTPUT(IOBPDoutput, np_write) USE DATAPOOL, only : MDC, IOBPD, np_total, MULTIPLEOUT_HIS, MNP # ifdef MPI_PARALL_GRID USE datapool, only : iplg, comm, nproc, istatus, ierr, myrank, itype # endif IMPLICIT NONE INTEGER, intent(in) :: np_write INTEGER, INTENT(OUT) :: IOBPDoutput(MDC, np_write) # ifdef MPI_PARALL_GRID integer, allocatable :: rIOBPD(:,:), rStatus(:), Status(:) integer iProc, IP, istat IF (MULTIPLEOUT_HIS .eq. 1) THEN IOBPDoutput=IOBPD ELSE allocate(rIOBPD(MDC, np_total), rStatus(np_total), Status(np_total), stat=istat) IF (istat/=0) CALL WWM_ABORT('wwm_netcdf, allocate error 7') IOBPDoutput=0 Status=0 DO IP=1,MNP IOBPDoutput(:, iplg(IP))=IOBPD(:,IP) Status(iplg(IP)) = 1 END DO IF (myrank .eq. 0) THEN DO iProc=2,nproc CALL MPI_RECV(rIOBPD, MDC*np_total, itype, iProc-1, 193, comm, istatus, ierr) CALL MPI_RECV(rStatus, np_total, itype, iProc-1, 197, comm, istatus, ierr) DO IP=1,np_total IF (rStatus(IP) .eq. 1) THEN IOBPDoutput(:,IP)=rIOBPD(:,IP) END IF END DO END DO DO iProc=2,nproc CALL MPI_SEND(IOBPDoutput, MDC*np_total, itype, iProc-1, 199, comm, ierr) END DO ELSE CALL MPI_SEND(IOBPDoutput, MDC*np_total, itype, 0, 193, comm, ierr) CALL MPI_SEND(Status, np_total, itype, 0, 197, comm, ierr) CALL MPI_RECV(IOBPDoutput, MDC*np_total, itype, 0, 199, comm, istatus, ierr) ENDIF deallocate(rIOBPD, rStatus, Status) END IF # else IOBPDoutput=IOBPD # endif END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_HEADERS_1(ncid, nbTime, MULTIPLEOUT, GRIDWRITE_W, IOBPD_HISTORY_W, np_write, ne_write) USE DATAPOOL USE NETCDF implicit none integer, intent(in) :: ncid, nbTime, MULTIPLEOUT integer, intent(in) :: np_write, ne_write logical, intent(in) :: GRIDWRITE_W, IOBPD_HISTORY_W ! character (len = *), parameter :: UNITS = "units" integer one_dims, two_dims, three_dims, fifteen_dims integer mnp_dims, mne_dims, nfreq_dims, ndir_dims # ifdef MPI_PARALL_GRID integer np_global_dims, ne_global_dims # endif integer iret, var_id integer ntime_dims integer p_dims, e_dims integer Oper character (len = *), parameter :: CallFct="WRITE_NETCDF_HEADERS_1" IF ((np_write.eq.0).or.(ne_write.eq.0)) THEN CALL WWM_ABORT('np_write=0 or ne_write=0, not allowed by any mean') ENDIF iret = nf90_def_dim(ncid, 'one', 1, one_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) iret = nf90_def_dim(ncid, 'two', 2, two_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) iret = nf90_def_dim(ncid, 'three', 3, three_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret = nf90_def_dim(ncid, 'fifteen', 15, fifteen_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) iret = nf90_def_dim(ncid, 'mnp', np_write, mnp_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret = nf90_def_dim(ncid, 'mne', ne_write, mne_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) iret = nf90_def_dim(ncid, 'nfreq', MSC, nfreq_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) iret = nf90_def_dim(ncid, 'ndir', MDC, ndir_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) # ifdef MPI_PARALL_GRID IF (MULTIPLEOUT.eq.1) THEN iret = nf90_def_dim(ncid, 'np_global', np_global, np_global_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret = nf90_def_dim(ncid, 'ne_global', ne_global, ne_global_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret = nf90_def_var(ncid,'iplg',NF90_INT,(/ mnp_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) iret = nf90_put_att(ncid,var_id,'description','local to global indexes') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_def_var(ncid,'nproc',NF90_INT,(/one_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) iret=nf90_put_att(ncid,var_id,'description','number of processors') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) END IF ! iret=nf90_def_var(ncid,'MULTIPLEOUT',NF90_INT,(/one_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) iret=nf90_put_att(ncid,var_id,'description','multiple status') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) # endif ! IF (PARAMWRITE_HIS) THEN CALL WRITE_PARAM_1(ncid, one_dims) ENDIF ! CALL WRITE_NETCDF_TIME_HEADER(ncid, nbTime, ntime_dims) ! IF (GRIDWRITE_W) THEN # ifdef MPI_PARALL_GRID IF (MULTIPLEOUT.eq.1) THEN e_dims=ne_global_dims p_dims=np_global_dims ELSE e_dims=mne_dims p_dims=mnp_dims END IF # else e_dims=mne_dims p_dims=mnp_dims # endif ! element iret=nf90_def_var(ncid,'ele',NF90_INT,(/three_dims, e_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 27, iret) iret=nf90_put_att(ncid,var_id,UNITS,'non-dimensional') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 28, iret) ! lon IF (LSPHE) THEN iret=nf90_def_var(ncid,"lon",NF90_RUNTYPE,(/ p_dims/),var_id) ELSE iret=nf90_def_var(ncid,"x",NF90_RUNTYPE,(/ p_dims/),var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 29, iret) IF (LSPHE) THEN iret=nf90_put_att(ncid,var_id,UNITS,'degree') ELSE iret=nf90_put_att(ncid,var_id,UNITS,'meter') END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 30, iret) ! lat IF (LSPHE) THEN iret=nf90_def_var(ncid,"lat",NF90_RUNTYPE,(/ p_dims/),var_id) ELSE iret=nf90_def_var(ncid,"y",NF90_RUNTYPE,(/ p_dims/),var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 31, iret) IF (LSPHE) THEN iret=nf90_put_att(ncid,var_id,UNITS,'degree') ELSE iret=nf90_put_att(ncid,var_id,UNITS,'meter') END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 32, iret) ! IOBP iret=nf90_def_var(ncid,"IOBP",NF90_RUNTYPE,(/ p_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 33, iret) ! depth iret=nf90_def_var(ncid,'depth',NF90_RUNTYPE,(/ p_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 34, iret) iret=nf90_put_att(ncid,var_id,UNITS,'meters') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 35, iret) ! boundary Oper=1 CALL SERIAL_WRITE_BOUNDARY(ncid, np_total, ne_total, INEtotal, Oper) ! END IF IF (IOBPD_HISTORY_W) THEN # ifdef MPI_PARALL_GRID IF (MULTIPLEOUT.eq.1) THEN p_dims=np_global_dims ELSE p_dims=mnp_dims END IF # else p_dims=mnp_dims # endif iret=nf90_def_var(ncid,'IOBPD',NF90_INT,(/ ndir_dims, p_dims, ntime_dims/), var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 20, iret) END IF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_HEADERS_2(FILERET, MULTIPLEOUT, WriteOutputProcess, GRIDWRITE_W, np_write, ne_write) USE DATAPOOL USE NETCDF implicit none character(len=140), intent(in) :: FILERET integer, intent(in) :: MULTIPLEOUT logical, intent(in) :: WriteOutputProcess, GRIDWRITE_W integer, intent(in) :: np_write, ne_write integer var_id, iret, ncid character (len = *), parameter :: CallFct="WRITE_NETCDF_HEADERS_2" integer Oper #ifdef MPI_PARALL_GRID integer eInt(1) #endif IF (WriteOutputProcess) THEN iret = nf90_open(FILERET, nf90_write, ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) END IF #ifdef MPI_PARALL_GRID IF (MULTIPLEOUT.eq.1) THEN iret=nf90_inq_varid(ncid, 'iplg', var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) iret=nf90_put_var(ncid,var_id,iplg,start=(/1/), count = (/ np_write /)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) END IF ! IF (WriteOutputProcess) THEN IF (MULTIPLEOUT.eq.1) THEN iret=nf90_inq_varid(ncid,'nproc',var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) eInt(1)=nproc iret=nf90_put_var(ncid,var_id,eInt,start = (/1/), count=(/1/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) END IF ! iret=nf90_inq_varid(ncid,'MULTIPLEOUT',var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) eInt(1)=MULTIPLEOUT iret=nf90_put_var(ncid,var_id,eInt,start = (/1/), count=(/1/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) END IF #endif IF (PARAMWRITE_HIS.and.WriteOutputProcess) THEN CALL WRITE_PARAM_2(ncid) END IF IF (GRIDWRITE_W.and.WriteOutputProcess) THEN ! iret=nf90_inq_varid(ncid, "ele", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) iret=nf90_put_var(ncid,var_id,INEtotal, start = (/1,1/), count = (/ 3, ne_total/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) ! IF (LSPHE) THEN iret=nf90_inq_varid(ncid, "lon", var_id) ELSE iret=nf90_inq_varid(ncid, "x", var_id) ENDIF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) iret=nf90_put_var(ncid,var_id,XPtotal, start = (/1/), count = (/ np_total/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) ! IF (LSPHE) THEN iret=nf90_inq_varid(ncid, "lat", var_id) ELSE iret=nf90_inq_varid(ncid, "y", var_id) ENDIF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) iret=nf90_put_var(ncid,var_id,YPtotal, start = (/1/), count = (/ np_total/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) ! iret=nf90_inq_varid(ncid, "IOBP", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) iret=nf90_put_var(ncid,var_id,IOBPtotal, start = (/1/), count = (/ np_total/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) ! iret=nf90_inq_varid(ncid, "depth", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) iret=nf90_put_var(ncid,var_id,DEPtotal, start = (/1/), count = (/ np_write/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) ! Oper=2 CALL SERIAL_WRITE_BOUNDARY(ncid, np_total, ne_total, INEtotal, Oper) ENDIF IF (WriteOutputProcess) THEN iret = nf90_close(ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 18, iret) END IF END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_PARAM_1(ncid, one_dims) USE NETCDF USE DATAPOOL, only : NF90_RUNTYPE implicit none integer, intent(in) :: ncid, one_dims integer :: iret, var_id character (len = *), parameter :: UNITS = "units" iret = nf90_def_var(ncid,'frlow', NF90_RUNTYPE,(/ one_dims/), var_id) CALL REPORT_ERROR_DEF(iret, 'frlow') iret = nf90_put_att(ncid,var_id,UNITS,'lower_frequency') ! iret = nf90_def_var(ncid,'frhigh',NF90_RUNTYPE,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'frhigh') iret = nf90_put_att(ncid,var_id,UNITS,'higher_frequency') ! iret = nf90_def_var(ncid,'MESNL',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'MESNL') iret = nf90_put_att(ncid,var_id,'description','nonlinear interaction nl4') ! iret = nf90_def_var(ncid,'MESIN',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'MESIN') iret = nf90_put_att(ncid,var_id,'description','wind input source term') ! iret = nf90_def_var(ncid,'MESDS',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'MESDS') iret = nf90_put_att(ncid,var_id,'description','dissipation source term') ! iret = nf90_def_var(ncid,'MESBF',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'MESBF') iret = nf90_put_att(ncid,var_id,'description','bottom friction') ! iret = nf90_def_var(ncid,'ICOMP',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'ICOMP') iret = nf90_put_att(ncid,var_id,'description','implicitness') ! iret = nf90_def_var(ncid,'AMETHOD',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'AMETHOD') iret = nf90_put_att(ncid,var_id,'description','advection method') ! iret = nf90_def_var(ncid,'FMETHOD',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'FMETHOD') iret = nf90_put_att(ncid,var_id,'description','frequency shifting method') ! iret = nf90_def_var(ncid,'DMETHOD',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'DMETHOD') iret = nf90_put_att(ncid,var_id,'description','directional shifting method(refraction)') ! iret = nf90_def_var(ncid,'SMETHOD',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'SMETHOD') iret = nf90_put_att(ncid,var_id,'description','source term integration method') ! iret = nf90_def_var(ncid,'LSPHE',NF90_INT,(/ one_dims/),var_id) CALL REPORT_ERROR_DEF(iret, 'LSPHE') iret = nf90_put_att(ncid,var_id,'description','spherical coordinates') END SUBROUTINE WRITE_PARAM_1 !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_PARAM_2(ncid) USE DATAPOOL, only : FRLOW, FRHIGH, ICOMP, AMETHOD, FMETHOD, & & DMETHOD, SMETHOD, MESIN, MESBF, MESDS, MESNL, LSPHE USE NETCDF IMPLICIT NONE integer, intent(in) :: ncid integer iret, var_id integer LSPHE_INT character (len = *), parameter :: CallFct="WRITE_PARAM_2" iret=nf90_inq_varid(ncid, "frlow", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) iret=nf90_put_var(ncid,var_id,FRLOW,start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) ! iret=nf90_inq_varid(ncid, "frhigh", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret=nf90_put_var(ncid,var_id,FRHIGH, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) ! iret=nf90_inq_varid(ncid, "MESIN", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) iret = nf90_put_var(ncid,var_id,MESIN, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) ! iret=nf90_inq_varid(ncid, "MESBF", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) iret=nf90_put_var(ncid,var_id,MESBF, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 18, iret) ! iret=nf90_inq_varid(ncid, "MESDS", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 19, iret) iret=nf90_put_var(ncid,var_id,MESDS, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 20, iret) ! iret=nf90_inq_varid(ncid, "MESNL", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 21, iret) iret=nf90_put_var(ncid,var_id,MESNL, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 22, iret) ! iret=nf90_inq_varid(ncid, "ICOMP", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret=nf90_put_var(ncid,var_id,ICOMP, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) ! iret=nf90_inq_varid(ncid, "AMETHOD", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) iret=nf90_put_var(ncid,var_id,AMETHOD, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) ! iret=nf90_inq_varid(ncid, "FMETHOD", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret=nf90_put_var(ncid,var_id,FMETHOD, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) ! iret=nf90_inq_varid(ncid, "DMETHOD", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_put_var(ncid,var_id,DMETHOD, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) ! iret=nf90_inq_varid(ncid, "SMETHOD", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) iret=nf90_put_var(ncid,var_id,SMETHOD, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) ! iret=nf90_inq_varid(ncid, "LSPHE", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) IF (LSPHE) THEN LSPHE_INT=1 ELSE LSPHE_INT=0 END IF iret=nf90_put_var(ncid,var_id,LSPHE_INT, start=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) END SUBROUTINE WRITE_PARAM_2 !********************************************************************** !* * !********************************************************************** SUBROUTINE DEFINE_STATION_NC(FILE_NAME, MULTIPLEOUT) USE NETCDF USE DATAPOOL implicit none character(len=256), intent(in) :: FILE_NAME integer, intent(in) :: MULTIPLEOUT character (len = *), parameter :: CallFct="DEFINE_STATION_NC" character (len = *), parameter :: UNITS = "units" character (len = *), parameter :: FULLNAME = "full-name" character(len=40) :: eStr, eStrUnit character(len=80) :: eStrFullName integer iret, ncid, nbstat_dims, ntime_dims, nfreq_dims, ndir_dims integer one_dims, three_dims, var_id, I iret = nf90_create(TRIM(FILE_NAME), NF90_CLOBBER, ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) CALL WRITE_NETCDF_HEADERS_STAT_1(ncid, -1, MULTIPLEOUT) iret=nf90_inq_dimid(ncid, 'nbstation', nbstat_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) iret=nf90_inq_dimid(ncid, 'ocean_time', ntime_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret=nf90_inq_dimid(ncid, 'nfreq', nfreq_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) iret=nf90_inq_dimid(ncid, 'ndir', ndir_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret=nf90_inq_dimid(ncid, 'one', one_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) iret=nf90_inq_dimid(ncid, 'three', three_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) IF (VAROUT_STATION%AC) THEN iret=nf90_def_var(ncid,'AC',NF90_OUTTYPE_STAT,(/nbstat_dims, nfreq_dims, ndir_dims, ntime_dims /),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_put_att(ncid,var_id,UNITS,'unk') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'spectral energy density') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) END IF IF (VAROUT_STATION%WK) THEN iret=nf90_def_var(ncid,'WK',NF90_OUTTYPE_STAT,(/nbstat_dims, nfreq_dims, ntime_dims /),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) iret=nf90_put_att(ncid,var_id,UNITS,'unk') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'wave number by frequency') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) END IF IF (VAROUT_STATION%ACOUT_1D) THEN iret=nf90_def_var(ncid,'ACOUT_1D',NF90_OUTTYPE_STAT,(/nbstat_dims, nfreq_dims, three_dims, ntime_dims /),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) iret=nf90_put_att(ncid,var_id,UNITS,'unk') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 18, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'1-dimensional spectrum') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 19, iret) END IF IF (VAROUT_STATION%ACOUT_2D) THEN iret=nf90_def_var(ncid,'ACOUT_2D',NF90_OUTTYPE_STAT,(/nbstat_dims, nfreq_dims, ndir_dims, ntime_dims /),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 20, iret) iret=nf90_put_att(ncid,var_id,UNITS,'unk') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 21, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,'2-dimensional spectrum') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 22, iret) END IF DO I=1,OUTVARS_COMPLETE IF (VAROUT_STATION%LVAR(I)) THEN CALL NAMEVARIABLE(I, eStr, eStrFullName, eStrUnit) iret=nf90_def_var(ncid,TRIM(eStr),NF90_OUTTYPE_STAT,(/ nbstat_dims, ntime_dims /),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 23, iret) iret=nf90_put_att(ncid,var_id,UNITS,TRIM(eStrUnit)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 24, iret) iret=nf90_put_att(ncid,var_id,FULLNAME,TRIM(eStrFullName)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 25, iret) END IF END DO iret=nf90_close(ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 26, iret) iret=nf90_open(TRIM(FILE_NAME), NF90_WRITE, ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 27, iret) CALL WRITE_NETCDF_HEADERS_STAT_2(ncid, MULTIPLEOUT_STAT) iret=nf90_close(ncid) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 28, iret) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_HEADERS_STAT_1(ncid, nbTime, MULTIPLEOUT) USE DATAPOOL USE NETCDF implicit none integer, intent(in) :: ncid, nbTime, MULTIPLEOUT character (len = *), parameter :: CallFct="WRITE_NETCDF_HEADERS_STAT_1" character (len = *), parameter :: UNITS = "units" integer one_dims, two_dims, three_dims, fifteen_dims integer nfreq_dims, ndir_dims integer nbstat_dims integer iret, var_id integer ntime_dims iret = nf90_def_dim(ncid, 'one', 1, one_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) iret = nf90_def_dim(ncid, 'two', 2, two_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) iret = nf90_def_dim(ncid, 'three', 3, three_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret = nf90_def_dim(ncid, 'fifteen', 15, fifteen_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) iret = nf90_def_dim(ncid, 'nbstation', IOUTS, nbstat_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret = nf90_def_dim(ncid, 'nfreq', MSC, nfreq_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) iret = nf90_def_dim(ncid, 'ndir', MDC, ndir_dims) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) ! # ifdef MPI_PARALL_GRID iret=nf90_def_var(ncid,'nproc',NF90_INT,(/one_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret=nf90_put_att(ncid,var_id,'description','number of processors') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) ! iret=nf90_def_var(ncid,'MULTIPLEOUT',NF90_INT,(/one_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) iret=nf90_put_att(ncid,var_id,'description','multiple status') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) # endif ! IF (PARAMWRITE_STAT) THEN CALL WRITE_PARAM_1(ncid, one_dims) ENDIF ! CALL WRITE_NETCDF_TIME_HEADER(ncid, nbTime, ntime_dims) IF (LSPHE) THEN iret=nf90_def_var(ncid,"lon",NF90_RUNTYPE,(/ nbstat_dims/),var_id) ELSE iret=nf90_def_var(ncid,"x",NF90_RUNTYPE,(/ nbstat_dims/),var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 23, iret) IF (LSPHE) THEN iret=nf90_put_att(ncid,var_id,UNITS,'degree') ELSE iret=nf90_put_att(ncid,var_id,UNITS,'meter') END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 24, iret) ! lat IF (LSPHE) THEN iret=nf90_def_var(ncid,"lat",NF90_RUNTYPE,(/ nbstat_dims/),var_id) ELSE iret=nf90_def_var(ncid,"y",NF90_RUNTYPE,(/ nbstat_dims/),var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 25, iret) IF (LSPHE) THEN iret=nf90_put_att(ncid,var_id,UNITS,'degree') ELSE iret=nf90_put_att(ncid,var_id,UNITS,'meter') END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 26, iret) ! cutoff frequency iret=nf90_def_var(ncid,'cutoff',NF90_RUNTYPE,(/ nbstat_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 27, iret) iret=nf90_put_att(ncid,var_id,UNITS,'Hz') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 28, iret) ! ismax value iret=nf90_def_var(ncid,'ismax',NF90_INT,(/ nbstat_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 29, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 30, iret) IF (MULTIPLEOUT.gt.0) THEN ! Ifound iret=nf90_def_var(ncid,'ifound',NF90_INT,(/ nbstat_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 31, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 32, iret) END IF ! Isum iret=nf90_def_var(ncid, 'isum', NF90_INT,(/ nbstat_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 33, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 34, iret) ! SPSIG iret=nf90_def_var(ncid, 'spsig', NF90_RUNTYPE,(/ nfreq_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 35, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 36, iret) ! SPDIR iret=nf90_def_var(ncid, 'spdir', NF90_RUNTYPE,(/ ndir_dims/),var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 31, iret) iret=nf90_put_att(ncid,var_id,UNITS,'integer') CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 37, iret) END SUBROUTINE !********************************************************************** !* * !********************************************************************** SUBROUTINE WRITE_NETCDF_HEADERS_STAT_2(ncid, MULTIPLEOUT) USE DATAPOOL USE NETCDF implicit none integer, intent(in) :: ncid, MULTIPLEOUT integer :: eWriteInt(1) real(rkind) :: eWriteReal(1) integer var_id, iret integer I # ifdef MPI_PARALL_GRID integer eInt(1) # endif character (len = *), parameter :: CallFct="WRITE_NETCDF_HEADERS_STAT_2" ! # ifdef MPI_PARALL_GRID iret=nf90_inq_varid(ncid,'nproc',var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) eInt(1)=nproc iret=nf90_put_var(ncid,var_id,eInt,start = (/1/), count=(/1/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) ! iret=nf90_inq_varid(ncid,'MULTIPLEOUT',var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) eInt(1)=MULTIPLEOUT iret=nf90_put_var(ncid,var_id,eInt,start = (/1/), count=(/1/)) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) # endif ! IF (PARAMWRITE_STAT) THEN CALL WRITE_PARAM_2(ncid) ENDIF DO I=1,IOUTS eWriteReal(1)=STATION(I) % XCOORD IF (LSPHE) THEN iret=nf90_inq_varid(ncid, "lon", var_id) ELSE iret=nf90_inq_varid(ncid, "x", var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 1, iret) iret=nf90_put_var(ncid,var_id,eWriteReal, start=(/I/), count =(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 2, iret) ! eWriteReal(1)=STATION(I) % YCOORD IF (LSPHE) THEN iret=nf90_inq_varid(ncid, "lat", var_id) ELSE iret=nf90_inq_varid(ncid, "y", var_id) END IF CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 3, iret) iret=nf90_put_var(ncid,var_id,eWriteReal, start=(/I/), count =(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 4, iret) ! eWriteReal(1)=STATION(I) % CUTOFF iret=nf90_inq_varid(ncid, "cutoff", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 5, iret) iret=nf90_put_var(ncid,var_id,eWriteReal, start=(/I/), count =(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 6, iret) ! eWriteInt(1)=STATION(I) % ISMAX iret=nf90_inq_varid(ncid, "ismax", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 7, iret) iret=nf90_put_var(ncid,var_id,eWriteInt, start=(/I/), count =(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 8, iret) # ifdef MPI_PARALL_GRID IF (MULTIPLEOUT.eq.0) THEN eWriteInt(1)=STATION(I) % ISUM iret=nf90_inq_varid(ncid, "isum", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 9, iret) iret=nf90_put_var(ncid,var_id,eWriteInt, start=(/I/), count=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 10, iret) ELSE eWriteInt(1)=STATION(I) % IFOUND iret=nf90_inq_varid(ncid, "ifound", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 11, iret) iret=nf90_put_var(ncid,var_id,eWriteInt, start=(/I/), count=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 12, iret) ! eWriteInt(1)=STATION(I) % ISUM iret=nf90_inq_varid(ncid, "isum", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 13, iret) iret=nf90_put_var(ncid,var_id,eWriteInt, start=(/I/), count=(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 14, iret) ENDIF # else eWriteInt(1)=STATION(I) % IFOUND iret=nf90_inq_varid(ncid, "isum", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 15, iret) iret=nf90_put_var(ncid,var_id,eWriteInt, start=(/I/), count =(/1/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 16, iret) # endif iret=nf90_inq_varid(ncid, "spsig", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 17, iret) iret=nf90_put_var(ncid,var_id,SPSIG, start=(/1/), count =(/MSC/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 18, iret) ! iret=nf90_inq_varid(ncid, "spdir", var_id) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 19, iret) iret=nf90_put_var(ncid,var_id,SPDIR, start=(/1/), count =(/MDC/) ) CALL GENERIC_NETCDF_ERROR_WWM(CallFct, 20, iret) ENDDO END SUBROUTINE #endif