From 6b630ed503cb10264f8757a0e1ce5a227551416a Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 26 Sep 2022 14:26:05 -0400 Subject: [PATCH] Fixes to allow auto-formatting (#804) co-author @mvertens --- model/src/PDLIB/yowelementpool.F90 | 4 +- model/src/PDLIB/yowerr.F90 | 4 +- model/src/PDLIB/yowexchangeModule.F90 | 20 +- model/src/PDLIB/yowfunction.F90 | 8 +- model/src/PDLIB/yownodepool.F90 | 12 +- model/src/PDLIB/yowpdlibmain.F90 | 18 +- model/src/PDLIB/yowrankModule.F90 | 12 +- model/src/constants.F90 | 12 +- model/src/ctest.F90 | 2 +- model/src/pdlib_field_vec.F90 | 6 +- model/src/w3fldsmd.F90 | 16 +- model/src/w3gridmd.F90 | 4 +- model/src/w3iobcmd.F90 | 8 +- model/src/w3meminfo.F90 | 12 +- model/src/w3parall.F90 | 24 +- model/src/w3partmd.F90 | 6 +- model/src/w3profsmd.F90 | 396 +++++++++++++------------- model/src/w3servmd.F90 | 16 +- model/src/w3sic3md.F90 | 2 +- model/src/w3snl4md.F90 | 245 ++++++++-------- model/src/w3src3md.F90 | 4 +- model/src/w3srcemd.F90 | 4 +- model/src/w3strkmd.F90 | 5 + model/src/w3tidemd.F90 | 164 +++++------ model/src/w3triamd.F90 | 20 +- model/src/w3updtmd.F90 | 3 +- model/src/w3wavset.F90 | 52 ++-- model/src/wminitmd.F90 | 23 +- model/src/wmscrpmd.F90 | 4 +- model/src/wmwavemd.F90 | 97 ++++--- model/src/ww3_prtide.F90 | 7 +- 31 files changed, 621 insertions(+), 589 deletions(-) diff --git a/model/src/PDLIB/yowelementpool.F90 b/model/src/PDLIB/yowelementpool.F90 index 3191dc999..8bf802491 100644 --- a/model/src/PDLIB/yowelementpool.F90 +++ b/model/src/PDLIB/yowelementpool.F90 @@ -95,7 +95,7 @@ function belongTo(ele_in, rank) belongTo = .true. END IF END DO - end function + end function belongTo subroutine finalizeElementpool() @@ -104,5 +104,5 @@ subroutine finalizeElementpool() if(allocated(INE)) deallocate(INE) !if(allocated(INE_global)) deallocate(INE_global) if(allocated(ielg)) deallocate(ielg) - end subroutine + end subroutine finalizeElementpool end module yowElementpool diff --git a/model/src/PDLIB/yowerr.F90 b/model/src/PDLIB/yowerr.F90 index e26e08582..b99c37a9c 100644 --- a/model/src/PDLIB/yowerr.F90 +++ b/model/src/PDLIB/yowerr.F90 @@ -158,7 +158,7 @@ subroutine abort(string, line, file, errno) write(*,*) stop - end subroutine + end subroutine abort !> print warning !> Call this to print an warning string and optional line number, and file @@ -216,5 +216,5 @@ subroutine warn(string, line, file) endif write(*,*) - end subroutine + end subroutine warn end module yowerr diff --git a/model/src/PDLIB/yowexchangeModule.F90 b/model/src/PDLIB/yowexchangeModule.F90 index 4c5d009be..c732497cd 100644 --- a/model/src/PDLIB/yowexchangeModule.F90 +++ b/model/src/PDLIB/yowexchangeModule.F90 @@ -95,7 +95,7 @@ module yowExchangeModule procedure :: finalize procedure :: createMPIType - end type + end type t_neighborDomain !> Knows for all domains neighbors, which node we must send or revc from neighbor domains !> from 1 to nConnDomains @@ -141,7 +141,7 @@ subroutine finalize(this) if(ierr /= MPI_SUCCESS) CALL PARALLEL_ABORT("freeMPItype", ierr) call mpi_type_free(this%p2DRrecvType2, ierr) if(ierr /= MPI_SUCCESS) CALL PARALLEL_ABORT("freeMPItype", ierr) - end subroutine + end subroutine finalize ! create MPI indexed datatype for this neighborDomain subroutine createMPIType(this) @@ -215,7 +215,7 @@ subroutine createMPIType(this) if(ierr /= MPI_SUCCESS) CALL PARALLEL_ABORT("createMPIType", ierr) - end subroutine + end subroutine createMPIType subroutine initNbrDomains(nConnD) use yowerr @@ -227,7 +227,7 @@ subroutine initNbrDomains(nConnD) nConnDomains = nConnD allocate(neighborDomains(nConnDomains), stat=stat) if(stat/=0) CALL ABORT('neighborDomains allocation failure') - end subroutine + end subroutine initNbrDomains subroutine createMPITypes() implicit none @@ -236,7 +236,7 @@ subroutine createMPITypes() do i=1, nConnDomains call neighborDomains(i)%createMPIType() end do - end subroutine + end subroutine createMPITypes !> exchange values in U. !> \param[inout] U array with values to exchange. np+ng long. @@ -289,7 +289,7 @@ subroutine PDLIB_exchange1Dreal(U) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) call mpi_waitall(nConnDomains, sendRqst, sendStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) - end subroutine + end subroutine PDLIB_exchange1Dreal !> \overload PDLIB_exchange1Dreal @@ -362,7 +362,7 @@ subroutine PDLIB_exchange2Dreal(U) WRITE(740+IAPROC,*) 'PDLIB_exchange2Dreal, step 12' FLUSH(740+IAPROC) #endif - end subroutine + end subroutine PDLIB_exchange2Dreal !> set the size of the second and third dimension for exchange @@ -384,7 +384,7 @@ subroutine finalizeExchangeModule() end do deallocate(neighborDomains) endif - end subroutine + end subroutine finalizeExchangeModule !> exchange values in U. !> \param[inout] U array with values to exchange. np+ng+1 long. !> U[0:npa] Send values from U(1:np) to other threads. @@ -458,7 +458,7 @@ subroutine PDLIB_exchange1Dreal_zero(U) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) call mpi_waitall(nConnDomains, sendRqst, sendStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) - end subroutine + end subroutine PDLIB_exchange1Dreal_zero !> \note MPI recv tag: 30001 + MPI rank !> \note MPI send tag: 30001 + neighbor MPI rank subroutine PDLIB_exchange2Dreal_zero(U) @@ -533,7 +533,7 @@ subroutine PDLIB_exchange2Dreal_zero(U) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) call mpi_waitall(nConnDomains, sendRqst, sendStat,ierr) if(ierr/=MPI_SUCCESS) CALL PARALLEL_ABORT("waitall", ierr) - end subroutine + end subroutine PDLIB_exchange2Dreal_zero end module yowExchangeModule diff --git a/model/src/PDLIB/yowfunction.F90 b/model/src/PDLIB/yowfunction.F90 index 0118f4ee6..5edaa8168 100644 --- a/model/src/PDLIB/yowfunction.F90 +++ b/model/src/PDLIB/yowfunction.F90 @@ -49,7 +49,7 @@ SUBROUTINE PDLIB_ABORT(istat) integer, intent(in) :: istat Print *, 'Error with istat=', istat CALL ABORT - END SUBROUTINE + END SUBROUTINE PDLIB_ABORT !********************************************************************** !* * !********************************************************************** @@ -187,7 +187,7 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel WRITE(740+IAPROC,*) 'ComputeListNP_ListNPA_Kernel, step 8' FLUSH(740+IAPROC) #endif - END SUBROUTINE + END SUBROUTINE ComputeListNP_ListNPA_ListIPLG_Kernel !********************************************************************** !* * !********************************************************************** @@ -275,7 +275,7 @@ SUBROUTINE ComputeListNP_ListNPA_ListIPLG FLUSH(740+IAPROC) #endif END IF - END SUBROUTINE + END SUBROUTINE ComputeListNP_ListNPA_ListIPLG !********************************************************************** !* * !********************************************************************** @@ -301,5 +301,5 @@ SUBROUTINE ComputeBoundaryInformation END DO NbSend(IPROC)=eSend END DO - END SUBROUTINE + END SUBROUTINE ComputeBoundaryInformation end module yowfunction diff --git a/model/src/PDLIB/yownodepool.F90 b/model/src/PDLIB/yownodepool.F90 index e23ce5d5f..3af3d31de 100644 --- a/model/src/PDLIB/yownodepool.F90 +++ b/model/src/PDLIB/yownodepool.F90 @@ -73,7 +73,7 @@ module yowNodepool !> returns true if this node is a ghost node procedure :: isGhost - end type + end type t_Node !> coordinates of the local + ghost nodes. range [1:npa] real(rkind), public, target, allocatable :: x(:), y(:), z(:) @@ -149,7 +149,7 @@ function connNodes(this, i) integer, intent(in) :: i type(t_Node), pointer :: connNodes connNodes => nodes_global(connNodes_data(this%id_global, i)) - end function + end function connNodes !> return pointer to the (global) node from the local id. !> This is in effekt iplg(id_local) @@ -160,7 +160,7 @@ function nodes(id_local) integer, intent(in) :: id_local type(t_Node), pointer :: nodes nodes => nodes_global(iplg(id_local)) - end function + end function nodes !> return pointer to the (global) (ghost) node !> Ghost nodes are nodes in the global node array, with the particularity @@ -173,7 +173,7 @@ function ghosts(id) integer, intent(in) :: id type(t_Node), pointer :: ghosts ghosts => nodes_global(ghostlg(id)) - end function + end function ghosts !> Insert a node number to the end of the conntected node array !> \param index optional - node number to insert. If it not present, just increas temporarily array lenght for later allocation @@ -214,7 +214,7 @@ function isGhost(this) else isGhost = .true. endif - end function + end function isGhost subroutine finalizeNodepool() implicit none @@ -230,5 +230,5 @@ subroutine finalizeNodepool() if(allocated(ghostgl)) deallocate(ghostgl) if(allocated(np_perProc)) deallocate(np_perProc) if(allocated(np_perProcSum)) deallocate(np_perProcSum) - end subroutine + end subroutine finalizeNodepool end module yowNodepool diff --git a/model/src/PDLIB/yowpdlibmain.F90 b/model/src/PDLIB/yowpdlibmain.F90 index 420409ea6..0646f95d5 100644 --- a/model/src/PDLIB/yowpdlibmain.F90 +++ b/model/src/PDLIB/yowpdlibmain.F90 @@ -249,7 +249,7 @@ SUBROUTINE REAL_MPI_BARRIER_PDLIB(TheComm, string) CALL MPI_RECV(iField, 1, MPI_INTEGER, 0, 712, TheComm, istatus, ierr) END IF ! Print *, 'Passing barrier string=', string - END SUBROUTINE + END SUBROUTINE REAL_MPI_BARRIER_PDLIB !-------------------------------------------------------------------------- ! Init MPI !-------------------------------------------------------------------------- @@ -458,7 +458,7 @@ subroutine findConnNodes(INE_global) node => nodes_global(i) ns_global = ns_global + node%nConnNodes end do - end subroutine + end subroutine findConnNodes !------------------------------------------------------------------------ @@ -993,7 +993,7 @@ subroutine findGhostNodes end do iplg(np+1: npa) = ghostlg(1:ng) - end subroutine + end subroutine findGhostNodes !------------------------------------------------------------------------------- ! find the number of connected domains and their ghosts !------------------------------------------------------------------------------- @@ -1336,7 +1336,7 @@ subroutine postPartition2(INE_global) z(np+i) = zb(IP_glob) end do - end subroutine + end subroutine postPartition2 !********************************************************************** !* * !********************************************************************** @@ -1401,7 +1401,7 @@ subroutine ComputeTRIA_IEN_SI_CCON PDLIB_TRIA03(IE) = TRIA03 ENDDO CALL PDLIB_exchange1Dreal(PDLIB_SI) - end subroutine + end subroutine ComputeTRIA_IEN_SI_CCON !********************************************************************** !* * !********************************************************************** @@ -1420,7 +1420,7 @@ subroutine ELEMENT_CROSSES_DATELINE(RX1, RX2, RX3, CROSSES_DATELINE) ! if R1GT180+R2GT180+R3GT180 .eq. 1 the element contains the pole ! if R1GT180+R2GT180+R3GT180 .eq. 2 the element crosses the dateline CROSSES_DATELINE = R1GT180+R2GT180+R3GT180 .EQ. 2 - end subroutine + end subroutine ELEMENT_CROSSES_DATELINE !********************************************************************** !* * !********************************************************************** @@ -1436,7 +1436,7 @@ subroutine CORRECT_DX_GT180(DXP) IF (DXP .ge. 180) THEN DXP=DXP - 360 END IF - end subroutine + end subroutine CORRECT_DX_GT180 !********************************************************************** !* * !********************************************************************** @@ -1630,7 +1630,7 @@ subroutine ComputeIA_JA_POSI_NNZ END DO END DO deallocate(PTABLE) - end subroutine + end subroutine ComputeIA_JA_POSI_NNZ !********************************************************************** !* * !********************************************************************** @@ -1645,7 +1645,7 @@ subroutine finalizePD() call finalizeExchangeModule() call finalizeElementpool() call finalizeNodepool() - end subroutine + end subroutine finalizePD end module yowpdlibMain !********************************************************************** diff --git a/model/src/PDLIB/yowrankModule.F90 b/model/src/PDLIB/yowrankModule.F90 index 2cf2c858a..98377ebac 100644 --- a/model/src/PDLIB/yowrankModule.F90 +++ b/model/src/PDLIB/yowrankModule.F90 @@ -60,7 +60,7 @@ module yowRankModule !> global start node number for every thread integer:: IStart = 0 - end type + end type t_rank !> Provides access to some information of all threads e.g. iplg !> \note range [1:nTasks] @@ -83,7 +83,7 @@ subroutine initRankModule() call exchangeIPLG() call calcISTART() - end subroutine + end subroutine initRankModule !> send iplg from this thread to every neighbor thread !> \internal @@ -231,7 +231,7 @@ subroutine exchangeIPLG() IPglob=rank(myrank+1)%iplg(J) ipgl_npa(IPglob)=J END DO - end subroutine + end subroutine exchangeIPLG !> \internal subroutine calcISTART() @@ -243,7 +243,7 @@ subroutine calcISTART() do ir=2, nTasks rank(ir)%IStart = rank(ir-1)%IStart + rank(ir-1)%np end do - end subroutine + end subroutine calcISTART subroutine finalizeRankModule() implicit none @@ -255,5 +255,5 @@ subroutine finalizeRankModule() end do deallocate(rank) endif - end subroutine -end module + end subroutine finalizeRankModule +end module yowRankModule diff --git a/model/src/constants.F90 b/model/src/constants.F90 index 52c94ff5c..b071b1705 100644 --- a/model/src/constants.F90 +++ b/model/src/constants.F90 @@ -299,7 +299,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) P2 = DSQRT(R2) L = 2.106D0*P2 + 4.4D0 IF (P2.LT.8.0D-1) L = 2.129D0*P2 + 4.0D0 - DO 20 N=1,INT(L) + DO N=1,INT(L) P1 = N P2 = N*N R1 = RTERM @@ -312,7 +312,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) T1 = T1 + 0.5D0/P1 RE1 = RE1 + (T1*RTERM-T2*ITERM)/P1 IM1 = IM1 + (T1*ITERM+T2*RTERM)/P1 - 20 CONTINUE + END DO R1 = X/R2 - 0.5D0*(X*RE1-Y*IM1) R2 = -Y/R2 - 0.5D0*(X*IM1+Y*RE1) P1 = DEXP(X) @@ -334,7 +334,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) IM0 = T1/P2 RE1 = 0.0D0 IM1 = 0.0D0 - DO 40 N=2,8 + DO N=2,8 T2 = X2 + TSQ(N) P1 = DSQRT(T2*T2+R1) P2 = DSQRT(P1+T2) @@ -344,7 +344,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) T1 = EXSQ(N)*TSQ(N) RE1 = RE1 + T1*P2 IM1 = IM1 + T1/P2 - 40 CONTINUE + END DO T2 = -Y2*IM0 RE1 = RE1/R2 R2 = Y2*IM1/R2 @@ -374,7 +374,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) R2 = 1.0D0 M = -8 K = 3 - DO 60 N=1,INT(L) + DO N=1,INT(L) M = M + 8 K = K - M R1 = FLOAT(K-4)*R1 @@ -387,7 +387,7 @@ SUBROUTINE KZEONE(X, Y, RE0, IM0, RE1, IM1) IM0 = IM0 + R1*ITERM RE1 = RE1 + R2*RTERM IM1 = IM1 + R2*ITERM - 60 CONTINUE + END DO T1 = DSQRT(P2+X) T2 = -Y/T1 P1 = 8.86226925452758D-1/P2 diff --git a/model/src/ctest.F90 b/model/src/ctest.F90 index 9a2077489..567121bae 100644 --- a/model/src/ctest.F90 +++ b/model/src/ctest.F90 @@ -42,4 +42,4 @@ SUBROUTINE CTEST !/ !/ End of CTEST ----------------------------------------------------- / !/ - END SUBROUTINE +END SUBROUTINE CTEST diff --git a/model/src/pdlib_field_vec.F90 b/model/src/pdlib_field_vec.F90 index 68760f6b4..0edcd6e8a 100644 --- a/model/src/pdlib_field_vec.F90 +++ b/model/src/pdlib_field_vec.F90 @@ -385,7 +385,7 @@ SUBROUTINE GET_ARRAY_SIZE(TheSize) END IF END DO TheSize=IH - END SUBROUTINE + END SUBROUTINE GET_ARRAY_SIZE !/ ------------------------------------------------------------------- / SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) !/ @@ -600,7 +600,7 @@ SUBROUTINE UNST_PDLIB_READ_FROM_FILE(NDREAD) IF (IAPROC .eq. 1) THEN deallocate(DATAread) END IF - END SUBROUTINE + END SUBROUTINE UNST_PDLIB_READ_FROM_FILE !/ ------------------------------------------------------------------- / SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) !/ @@ -780,7 +780,7 @@ SUBROUTINE UNST_PDLIB_WRITE_TO_FILE(NDWRITE) END IF END IF END DO - END SUBROUTINE + END SUBROUTINE UNST_PDLIB_WRITE_TO_FILE !/ ------------------------------------------------------------------- / SUBROUTINE DO_OUTPUT_EXCHANGES(IMOD) !/ diff --git a/model/src/w3fldsmd.F90 b/model/src/w3fldsmd.F90 index 40484358c..5e14589bd 100644 --- a/model/src/w3fldsmd.F90 +++ b/model/src/w3fldsmd.F90 @@ -1961,8 +1961,8 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ICLO = ICLO_NONE IF ( FLAGLL .AND. CLOSED ) ICLO = ICLO_SMPL ! - DO 110, IX=1, NX - DO 100, IY=1, NY + DO IX=1, NX + DO IY=1, NY RD11(IX,IY) = 0. RD12(IX,IY) = 0. RD21(IX,IY) = 0. @@ -1971,8 +1971,8 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & IX2(IX,IY) = 1 IY1(IX,IY) = 1 IY2(IX,IY) = 1 - 100 CONTINUE - 110 CONTINUE + END DO + END DO ! ! 1.b Setup logical mask ! @@ -1991,8 +1991,8 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ! ! 2. Loop over output grid ------------------------------------------ * ! - DO 500, IY=1, NY - DO 400, IX=1, NX + DO IY=1, NY + DO IX=1, NX ! X = TLON(IY,IX) Y = TLAT(IY,IX) @@ -2088,8 +2088,8 @@ SUBROUTINE W3FLDP ( NDSM, NDST, NDSE, IERR, FLAGLL, & ! ! ... End loop over output grid -------------------------------------- * ! - 400 CONTINUE - 500 CONTINUE + END DO + END DO ! ! 3. Finalizations -------------------------------------------------- * ! 3.a Final output diff --git a/model/src/w3gridmd.F90 b/model/src/w3gridmd.F90 index 1dbf8a90a..df2d96711 100644 --- a/model/src/w3gridmd.F90 +++ b/model/src/w3gridmd.F90 @@ -7155,7 +7155,7 @@ SUBROUTINE W3GRID() 9096 FORMAT ( ' ',I3,2I8) #endif - END SUBROUTINE + END SUBROUTINE W3GRID !/ !/ Internal function READNL ------------------------------------------ / !/ @@ -7473,7 +7473,7 @@ SUBROUTINE READNL ( NDS, NAME, STATUS ) !/ !/ End of READNL ----------------------------------------------------- / !/ - END SUBROUTINE + END SUBROUTINE READNL !/ !/ End of W3GRID ----------------------------------------------------- / !/ diff --git a/model/src/w3iobcmd.F90 b/model/src/w3iobcmd.F90 index c06f3f48d..f82c24d7a 100644 --- a/model/src/w3iobcmd.F90 +++ b/model/src/w3iobcmd.F90 @@ -752,11 +752,11 @@ SUBROUTINE W3IOBC ( INXOUT, NDSB, TIME1, TIME2, IOTST, IMOD ) #endif TIME1(1) = TIME2(1) TIME1(2) = TIME2(2) - DO 812, IP=0, NBI2 - DO 811, ISP=1, NSPEC + DO IP=0, NBI2 + DO ISP=1, NSPEC ABPI0(ISP,IP) = ABPIN(ISP,IP) - 811 CONTINUE - 812 CONTINUE + END DO + END DO ! IOTST = -1 FLBPI = .FALSE. diff --git a/model/src/w3meminfo.F90 b/model/src/w3meminfo.F90 index d743277d9..aa87f21cc 100644 --- a/model/src/w3meminfo.F90 +++ b/model/src/w3meminfo.F90 @@ -88,7 +88,7 @@ module MallocInfo_m integer(c_int) :: fordblks !> This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space’s data segment). integer(c_int) :: keepcost - end type + end type MallInfo_t interface function mallinfo() bind(c, name="mallinfo") result(data) @@ -106,9 +106,9 @@ function mallinfo() bind(c, name="mallinfo") result(data) integer(c_int) :: uordblks integer(c_int) :: fordblks integer(c_int) :: keepcost - end type + end type MallInfo_t type(MallInfo_t) :: data - end function + end function mallinfo end interface contains @@ -181,7 +181,7 @@ subroutine getMallocInfo(malinfo) #endif type(MallInfo_t), intent(out) :: malinfo malinfo = mallinfo() - end subroutine + end subroutine getMallocInfo subroutine printMallInfo(ihdnl,malinfo) !/ @@ -269,7 +269,7 @@ subroutine printMallInfo(ihdnl,malinfo) write(ihdnl,'(A72,2F20.10)') "VM size in proc ", vmsize/1024. write(ihdnl,'(A72,2F20.10)') "RSS size in prof ", vmRSS/1024. call flush(ihdnl) - end subroutine + end subroutine printMallInfo !VmPeak: Peak virtual memory usage !VmSize: Current virtual memory usage @@ -455,7 +455,7 @@ function getVmRSS() result(vmRSS) vmRSS = -1 end function getVmRSS -end module +end module MallocInfo_m !program test ! use MallocInfo_m diff --git a/model/src/w3parall.F90 b/model/src/w3parall.F90 index 478f3e70d..e8b901cd5 100644 --- a/model/src/w3parall.F90 +++ b/model/src/w3parall.F90 @@ -156,7 +156,7 @@ SUBROUTINE WAV_MY_WTIME(eTime) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE WAV_MY_WTIME !/ ------------------------------------------------------------------- / SUBROUTINE PRINT_MY_TIME(string) !/ @@ -231,7 +231,7 @@ SUBROUTINE PRINT_MY_TIME(string) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE PRINT_MY_TIME !/ ------------------------------------------------------------------- / SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) !/ @@ -380,7 +380,7 @@ SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE PROP_REFRACTION_PR1 !/ ------------------------------------------------------------------- / ! SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) @@ -528,7 +528,7 @@ SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE PROP_REFRACTION_PR3 !/ ------------------------------------------------------------------- / SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) !/ @@ -667,7 +667,7 @@ SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE PROP_FREQ_SHIFT !/ ------------------------------------------------------------------- / SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) !/ @@ -812,7 +812,7 @@ SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE PROP_FREQ_SHIFT_M2 !/ ------------------------------------------------------------------- / SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) !/ @@ -926,7 +926,7 @@ SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY !/ ....................----------------------------------------------- / SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) !/ @@ -1038,7 +1038,7 @@ SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE SET_UP_NSEAL_NSEALM !/ ------------------------------------------------------------------- / SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) !/ ------------------------------------------------------------------- / @@ -1135,7 +1135,7 @@ SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE INIT_GET_JSEA_ISPROC !/ ------------------------------------------------------------------- / SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) !/ ------------------------------------------------------------------- / @@ -1252,7 +1252,7 @@ SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) !/ !/ End of INIT_GET_ISEA ---------------------------------------------- / !/ - END SUBROUTINE + END SUBROUTINE GET_JSEA_IBELONG !/ ------------------------------------------------------------------- / SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) !/ ------------------------------------------------------------------- / @@ -1359,7 +1359,7 @@ SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) !/ !/ End of INIT_GET_ISEA ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE INIT_GET_ISEA !********************************************************************** !* An array of size (NSEA) is send but only the (1:NSEAL) values * !* are correct. The program synchonizes everything on all nodes. * @@ -1476,7 +1476,7 @@ SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) !/ !/ End of JACOBI_INIT ------------------------------------------------ / !/ - END SUBROUTINE + END SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY !/ ------------------------------------------------------------------- / END MODULE W3PARALL !/ ------------------------------------------------------------------- / diff --git a/model/src/w3partmd.F90 b/model/src/w3partmd.F90 index 5ffddcbe3..95a5c98f3 100644 --- a/model/src/w3partmd.F90 +++ b/model/src/w3partmd.F90 @@ -1114,7 +1114,7 @@ SUBROUTINE FIFO_ADD ( IV ) IF ( IQ_END .GT. NSPEC ) IQ_END = 1 ! RETURN - END SUBROUTINE + END SUBROUTINE FIFO_ADD !/ ------------------------------------------------------------------- / !> @brief Check if queue is empty. !> @@ -1134,7 +1134,7 @@ SUBROUTINE FIFO_EMPTY ( IEMPTY ) END IF ! RETURN - END SUBROUTINE + END SUBROUTINE FIFO_EMPTY !/ ------------------------------------------------------------------- / !> @brief Get point out of queue. !> @@ -1153,7 +1153,7 @@ SUBROUTINE FIFO_FIRST ( IV ) IF ( IQ_START .GT. NSPEC ) IQ_START = 1 ! RETURN - END SUBROUTINE + END SUBROUTINE FIFO_FIRST !/ !/ End of PT_FLD ----------------------------------------------------- / !/ diff --git a/model/src/w3profsmd.F90 b/model/src/w3profsmd.F90 index ca08bd182..71e2cdc09 100644 --- a/model/src/w3profsmd.F90 +++ b/model/src/w3profsmd.F90 @@ -1658,7 +1658,7 @@ SUBROUTINE SETDEPTH !WRITE(*,*) ip, ip_glob, MAPSTA(1,IP_glob), IOBP(IP_glob), DW(ISEA), DMIN END DO - END SUBROUTINE + END SUBROUTINE SETDEPTH !/ ------------------------------------------------------------------- / @@ -2333,7 +2333,7 @@ subroutine bcgstab(n, rhs, sol, ipar, fpar, w) ! return !-----end-of-bcgstab - end +end subroutine bcgstab !----------------------------------------------------------------------- subroutine implu(np,umm,beta,ypiv,u,permut,full) real*8 umm,beta,ypiv(*),u(*),x, xpiv @@ -2348,13 +2348,13 @@ subroutine implu(np,umm,beta,ypiv,u,permut,full) ! ! -- perform previous step of the factorization- ! - do 6 k=1,npm1 + do k=1,npm1 if (.not. permut(k)) goto 5 x=u(k) u(k) = u(k+1) u(k+1) = x 5 u(k+1) = u(k+1) - ypiv(k)*u(k) - 6 continue + end do !----------------------------------------------------------------------- ! now determine pivotal information to be used in the next call !----------------------------------------------------------------------- @@ -2369,13 +2369,13 @@ subroutine implu(np,umm,beta,ypiv,u,permut,full) ypiv(np) = xpiv if (.not. full) return ! shift everything up if full... - do 7 k=1,npm1 + do k=1,npm1 ypiv(k) = ypiv(k+1) permut(k) = permut(k+1) - 7 continue + end do return !-----end-of-implu - end +end subroutine implu !----------------------------------------------------------------------- subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) implicit none @@ -2398,9 +2398,9 @@ subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) 10 if (j .le. 0) j=lbp x = u(ju) /usav(j) if (x .eq. zero) goto 115 - do 11 k=1,n + do k=1,n y(k) = y(k) - x*p(k,j) - 11 continue + end do flops = flops + 2*n 115 j = j-1 ju = ju -1 @@ -2408,13 +2408,13 @@ subroutine uppdir(n,p,np,lbp,indp,y,u,usav,flops) 12 indp = indp + 1 if (indp .gt. lbp) indp = 1 usav(indp) = u(np) - do 13 k=1,n + do k=1,n p(k,indp) = y(k) - 13 continue + end do return !----------------------------------------------------------------------- !-------end-of-uppdir--------------------------------------------------- - end +end subroutine uppdir subroutine givens(x,y,c,s) implicit none @@ -2455,7 +2455,7 @@ subroutine givens(x,y,c,s) ! end of givens ! return - end +end subroutine givens !-----end-of-givens !----------------------------------------------------------------------- logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) @@ -2513,7 +2513,7 @@ logical function stopbis(n,ipar,mvpi,fpar,r,delx,sx) endif ! return - end +end function stopbis !-----end-of-stopbis !----------------------------------------------------------------------- subroutine tidycg(n,ipar,fpar,sol,delx) @@ -2547,7 +2547,7 @@ subroutine tidycg(n,ipar,fpar,sol,delx) sol(i) = sol(i) + delx(i) enddo return - end +end subroutine tidycg !-----end-of-tidycg !----------------------------------------------------------------------- logical function brkdn(alpha, ipar) @@ -2583,7 +2583,7 @@ logical function brkdn(alpha, ipar) ipar(1) = -9 endif return - end +end function brkdn !-----end-of-brkdn !----------------------------------------------------------------------- subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) @@ -2655,7 +2655,7 @@ subroutine bisinit(ipar,fpar,wksize,dsc,lp,rp,wk) ! return !-----end-of-bisinit - end +end subroutine bisinit !----------------------------------------------------------------------- subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) implicit none @@ -2715,46 +2715,46 @@ subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) ! Modified Gram-Schmidt loop ! if (full) then - do 40 i = ind+1, m + do i = ind+1, m fct = ddot(n,vec(1,ind),vec(1,i)) hh(i) = fct - do 20 k = 1, n + do k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) - 20 continue + end do ops = ops + 4 * n + 2 if (fct*fct.gt.thr) then fct = ddot(n,vec(1,ind),vec(1,i)) hh(i) = hh(i) + fct - do 30 k = 1, n + do k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) - 30 continue + end do ops = ops + 4*n + 1 endif nrm0 = nrm0 - hh(i) * hh(i) if (nrm0.lt.zero) nrm0 = zero thr = nrm0 * reorth - 40 continue + end do endif ! - do 70 i = 1, ind-1 + do i = 1, ind-1 fct = ddot(n,vec(1,ind),vec(1,i)) hh(i) = fct - do 50 k = 1, n + do k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) - 50 continue + end do ops = ops + 4 * n + 2 if (fct*fct.gt.thr) then fct = ddot(n,vec(1,ind),vec(1,i)) hh(i) = hh(i) + fct - do 60 k = 1, n + do k = 1, n vec(k,ind) = vec(k,ind) - fct * vec(k,i) - 60 continue + end do ops = ops + 4*n + 1 endif nrm0 = nrm0 - hh(i) * hh(i) if (nrm0.lt.zero) nrm0 = zero thr = nrm0 * reorth - 70 continue + end do ! ! test the resulting vector ! @@ -2769,17 +2769,17 @@ subroutine mgsro(full,lda,n,m,ind,ops,vec,hh,ierr) ! scale the resulting vector ! fct = one / nrm1 - do 80 k = 1, n + do k = 1, n vec(k,ind) = vec(k,ind) * fct - 80 continue + end do ops = ops + n + 1 ! ! normal return ! ierr = 0 return -! end surbotine mgsro - end + ! end subroutine mgsro +end subroutine mgsro !----------------------------------------------------------------------c ! S P A R S K I T c !----------------------------------------------------------------------c @@ -2840,24 +2840,24 @@ subroutine amux (n, x, y, a,ja,ia) real*8 t integer i, k !----------------------------------------------------------------------- - do 100 i = 1,n + do i = 1,n ! ! compute the inner product of row i with vector x ! t = 0.0d0 - do 99 k=ia(i), ia(i+1)-1 + do k=ia(i), ia(i+1)-1 t = t + a(k)*x(ja(k)) - 99 continue + end do ! ! store result in y(i) ! y(i) = t - 100 continue + end do ! return !---------end-of-amux--------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine amux !----------------------------------------------------------------------- subroutine amuxms (n, x, y, a,ja) real*8 x(*), y(*), a(*) @@ -2884,22 +2884,22 @@ subroutine amuxms (n, x, y, a,ja) ! integer i, k !----------------------------------------------------------------------- - do 10 i=1, n + do i=1, n y(i) = a(i)*x(i) - 10 continue - do 100 i = 1,n + end do + do i = 1,n ! ! compute the inner product of row i with vector x ! - do 99 k=ja(i), ja(i+1)-1 + do k=ja(i), ja(i+1)-1 y(i) = y(i) + a(k) *x(ja(k)) - 99 continue - 100 continue + end do + end do ! return !---------end-of-amuxm-------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine amuxms !----------------------------------------------------------------------- subroutine atmux (n, x, y, a, ja, ia) real*8 x(*), y(*), a(*) @@ -2933,22 +2933,22 @@ subroutine atmux (n, x, y, a, ja, ia) ! ! zero out output vector ! - do 1 i=1,n + do i=1,n y(i) = 0.0 - 1 continue + end do ! ! loop over the rows ! - do 100 i = 1,n - do 99 k=ia(i), ia(i+1)-1 + do i = 1,n + do k=ia(i), ia(i+1)-1 y(ja(k)) = y(ja(k)) + x(i)*a(k) - 99 continue - 100 continue + end do + end do ! return !-------------end-of-atmux---------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine atmux !----------------------------------------------------------------------- subroutine atmuxr (m, n, x, y, a, ja, ia) real*8 x(*), y(*), a(*) @@ -2982,22 +2982,22 @@ subroutine atmuxr (m, n, x, y, a, ja, ia) ! ! zero out output vector ! - do 1 i=1,m + do i=1,m y(i) = 0.0 - 1 continue + end do ! ! loop over the rows ! - do 100 i = 1,n - do 99 k=ia(i), ia(i+1)-1 + do i = 1,n + do k=ia(i), ia(i+1)-1 y(ja(k)) = y(ja(k)) + x(i)*a(k) - 99 continue - 100 continue + end do + end do ! return !-------------end-of-atmuxr--------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine atmuxr !----------------------------------------------------------------------- subroutine amuxe (n,x,y,na,ncol,a,ja) implicit none @@ -3034,19 +3034,19 @@ subroutine amuxe (n,x,y,na,ncol,a,ja) ! integer i, j !----------------------------------------------------------------------- - do 1 i=1, n + do i=1, n y(i) = 0.0 - 1 continue - do 10 j=1,ncol - do 25 i = 1,n + end do + do j=1,ncol + do i = 1,n y(i) = y(i)+a(i,j)*x(ja(i,j)) - 25 continue - 10 continue + end do + end do ! return !--------end-of-amuxe--------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine amuxe !----------------------------------------------------------------------- subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff) integer n, ndiag, idiag, ioff(idiag) @@ -3083,22 +3083,22 @@ subroutine amuxd (n,x,y,diag,ndiag,idiag,ioff) ! integer j, k, io, i1, i2 !----------------------------------------------------------------------- - do 1 j=1, n + do j=1, n y(j) = 0.0d0 - 1 continue - do 10 j=1, idiag + end do + do j=1, idiag io = ioff(j) i1 = max0(1,1-io) i2 = min0(n,n-io) - do 9 k=i1, i2 + do k=i1, i2 y(k) = y(k)+diag(k,j)*x(k+io) - 9 continue - 10 continue + end do + end do ! return !----------end-of-amuxd------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine amuxd !----------------------------------------------------------------------- subroutine amuxj (n, x, y, jdiag, a, ja, ia) integer n, jdiag, ja(*), ia(*) @@ -3138,21 +3138,21 @@ subroutine amuxj (n, x, y, jdiag, a, ja, ia) ! integer i, ii, k1, ilen, j !----------------------------------------------------------------------- - do 1 i=1, n + do i=1, n y(i) = 0.0d0 - 1 continue - do 70 ii=1, jdiag + end do + do ii=1, jdiag k1 = ia(ii)-1 ilen = ia(ii+1)-k1-1 - do 60 j=1,ilen + do j=1,ilen y(j)= y(j)+a(k1+j)*x(ja(k1+j)) - 60 continue - 70 continue + end do + end do ! return !----------end-of-amuxj------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine amuxj !----------------------------------------------------------------------- subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b) !----------------------------------------------------------------------- @@ -3201,7 +3201,7 @@ subroutine vbrmv(nr, nc, ia, ja, ka, a, kvstr, kvstc, x, b) enddo !--------------------------------- return - end +end subroutine vbrmv !----------------------------------------------------------------------- !----------------------end-of-vbrmv------------------------------------- !----------------------------------------------------------------------- @@ -3238,18 +3238,18 @@ subroutine lsol (n,x,y,al,jal,ial) real*8 t !----------------------------------------------------------------------- x(1) = y(1) - do 150 k = 2, n + do k = 2, n t = y(k) - do 100 j = ial(k), ial(k+1)-1 + do j = ial(k), ial(k+1)-1 t = t-al(j)*x(jal(j)) - 100 continue + end do x(k) = t - 150 continue + end do ! return !----------end-of-lsol-------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine lsol !----------------------------------------------------------------------- subroutine ldsol (n,x,y,al,jal) integer n, jal(*) @@ -3282,17 +3282,17 @@ subroutine ldsol (n,x,y,al,jal) real*8 t !----------------------------------------------------------------------- x(1) = y(1)*al(1) - do 150 k = 2, n + do k = 2, n t = y(k) - do 100 j = jal(k), jal(k+1)-1 + do j = jal(k), jal(k+1)-1 t = t - al(j)*x(jal(j)) - 100 continue + end do x(k) = al(k)*t - 150 continue + end do return !----------end-of-ldsol------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine ldsol !----------------------------------------------------------------------- subroutine lsolc (n,x,y,al,jal,ial) integer n, jal(*),ial(*) @@ -3323,20 +3323,20 @@ subroutine lsolc (n,x,y,al,jal,ial) integer k, j real*8 t !----------------------------------------------------------------------- - do 140 k=1,n + do k=1,n x(k) = y(k) - 140 continue - do 150 k = 1, n-1 + end do + do k = 1, n-1 t = x(k) - do 100 j = ial(k), ial(k+1)-1 + do j = ial(k), ial(k+1)-1 x(jal(j)) = x(jal(j)) - t*al(j) - 100 continue - 150 continue + end do + end do ! return !----------end-of-lsolc------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine lsolc !----------------------------------------------------------------------- subroutine ldsolc (n,x,y,al,jal) integer n, jal(*) @@ -3369,21 +3369,21 @@ subroutine ldsolc (n,x,y,al,jal) integer k, j real*8 t !----------------------------------------------------------------------- - do 140 k=1,n + do k=1,n x(k) = y(k) - 140 continue - do 150 k = 1, n + end do + do k = 1, n x(k) = x(k)*al(k) t = x(k) - do 100 j = jal(k), jal(k+1)-1 + do j = jal(k), jal(k+1)-1 x(jal(j)) = x(jal(j)) - t*al(j) - 100 continue - 150 continue + end do + end do ! return !----------end-of-lsolc------------------------------------------------ !----------------------------------------------------------------------- - end +end subroutine ldsolc !----------------------------------------------------------------------- subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev) integer n, nlev, jal(*), ilev(nlev+1), lev(n) @@ -3417,25 +3417,25 @@ subroutine ldsoll (n,x,y,al,jal,nlev,lev,ilev) ! ! outer loop goes through the levels. (SEQUENTIAL loop) ! - do 150 ii=1, nlev + do ii=1, nlev ! ! next loop executes within the same level. PARALLEL loop ! - do 100 i=ilev(ii), ilev(ii+1)-1 + do i=ilev(ii), ilev(ii+1)-1 jrow = lev(i) ! ! compute inner product of row jrow with x ! t = y(jrow) - do 130 k=jal(jrow), jal(jrow+1)-1 + do k=jal(jrow), jal(jrow+1)-1 t = t - al(k)*x(jal(k)) - 130 continue + end do x(jrow) = t*al(jrow) - 100 continue - 150 continue + end do + end do return !----------------------------------------------------------------------- - end +end subroutine ldsoll !----------------------------------------------------------------------- subroutine usol (n,x,y,au,jau,iau) integer n, jau(*),iau(n+1) @@ -3467,18 +3467,18 @@ subroutine usol (n,x,y,au,jau,iau) real*8 t !----------------------------------------------------------------------- x(n) = y(n) - do 150 k = n-1,1,-1 + do k = n-1,1,-1 t = y(k) - do 100 j = iau(k), iau(k+1)-1 + do j = iau(k), iau(k+1)-1 t = t - au(j)*x(jau(j)) - 100 continue + end do x(k) = t - 150 continue + end do ! return !----------end-of-usol-------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine usol !----------------------------------------------------------------------- subroutine udsol (n,x,y,au,jau) integer n, jau(*) @@ -3511,18 +3511,18 @@ subroutine udsol (n,x,y,au,jau) real*8 t !----------------------------------------------------------------------- x(n) = y(n)*au(n) - do 150 k = n-1,1,-1 + do k = n-1,1,-1 t = y(k) - do 100 j = jau(k), jau(k+1)-1 + do j = jau(k), jau(k+1)-1 t = t - au(j)*x(jau(j)) - 100 continue + end do x(k) = au(k)*t - 150 continue + end do ! return !----------end-of-udsol------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine udsol !----------------------------------------------------------------------- subroutine usolc (n,x,y,au,jau,iau) real*8 x(*), y(*), au(*) @@ -3553,20 +3553,20 @@ subroutine usolc (n,x,y,au,jau,iau) integer k, j real*8 t !----------------------------------------------------------------------- - do 140 k=1,n + do k=1,n x(k) = y(k) - 140 continue - do 150 k = n,1,-1 + end do + do k = n,1,-1 t = x(k) - do 100 j = iau(k), iau(k+1)-1 + do j = iau(k), iau(k+1)-1 x(jau(j)) = x(jau(j)) - t*au(j) - 100 continue - 150 continue + end do + end do ! return !----------end-of-usolc------------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine usolc !----------------------------------------------------------------------- subroutine udsolc (n,x,y,au,jau) integer n, jau(*) @@ -3598,21 +3598,21 @@ subroutine udsolc (n,x,y,au,jau) integer k, j real*8 t !----------------------------------------------------------------------- - do 140 k=1,n + do k=1,n x(k) = y(k) - 140 continue - do 150 k = n,1,-1 + end do + do k = n,1,-1 x(k) = x(k)*au(k) t = x(k) - do 100 j = jau(k), jau(k+1)-1 + do j = jau(k), jau(k+1)-1 x(jau(j)) = x(jau(j)) - t*au(j) - 100 continue - 150 continue + end do + end do ! return !----------end-of-udsolc------------------------------------------------ !----------------------------------------------------------------------- - end +end subroutine udsolc !----------------------------------------------------------------------- subroutine lusol(n, y, x, alu, jlu, ju) implicit none @@ -3625,22 +3625,22 @@ subroutine lusol(n, y, x, alu, jlu, ju) ! ! forward solve ! - do 40 i = 1, n + do i = 1, n x(i) = y(i) - do 41 k=jlu(i),ju(i)-1 + do k=jlu(i),ju(i)-1 x(i) = x(i) - alu(k)* x(jlu(k)) - 41 continue - 40 continue - do 90 i = n, 1, -1 - do 91 k=ju(i),jlu(i+1)-1 + end do + end do + do i = n, 1, -1 + do k=ju(i),jlu(i+1)-1 x(i) = x(i) - alu(k)*x(jlu(k)) - 91 continue + end do x(i) = alu(i)*x(i) - 90 continue + end do ! return !----------------end of lusol ------------------------------------------ - end +end subroutine lusol !----------------------------------------------------------------------- subroutine lutsol(n, y, x, alu, jlu, ju) implicit none @@ -3653,31 +3653,31 @@ subroutine lutsol(n, y, x, alu, jlu, ju) ! integer :: i,k ! - do 10 i = 1, n + do i = 1, n x(i) = y(i) - 10 continue + end do ! ! forward solve (with U^T) ! - do 20 i = 1, n + do i = 1, n x(i) = x(i) * alu(i) - do 30 k=ju(i),jlu(i+1)-1 + do k=ju(i),jlu(i+1)-1 x(jlu(k)) = x(jlu(k)) - alu(k)* x(i) - 30 continue - 20 continue + end do + end do ! ! backward solve (with L^T) ! - do 40 i = n, 1, -1 - do 50 k=jlu(i),ju(i)-1 + do i = n, 1, -1 + do k=jlu(i),ju(i)-1 x(jlu(k)) = x(jlu(k)) - alu(k)*x(i) - 50 continue - 40 continue + end do + end do ! return !----------------end of lutsol ----------------------------------------- !----------------------------------------------------------------------- - end +end subroutine lutsol !----------------------------------------------------------------------- subroutine qsplit(a,ind,n,ncut) implicit none @@ -3706,7 +3706,7 @@ subroutine qsplit(a,ind,n,ncut) ! 1 mid = first abskey = abs(a(mid)) - do 2 j=first+1, last + do j=first+1, last if (abs(a(j)) .gt. abskey) then mid = mid+1 ! interchange @@ -3717,7 +3717,7 @@ subroutine qsplit(a,ind,n,ncut) a(j) = tmp ind(j) = itmp endif - 2 continue + end do ! ! interchange ! @@ -3740,7 +3740,7 @@ subroutine qsplit(a,ind,n,ncut) goto 1 !----------------end-of-qsplit------------------------------------------ !----------------------------------------------------------------------- - end +end subroutine qsplit subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver) implicit none integer n,ipar(16),ia(n+1),ja(*),ju(*),jau(*) @@ -3809,7 +3809,7 @@ subroutine runrc(n,rhs,sol,ipar,fpar,wk,guess,a,ja,ia,au,jau,ju,solver) WRITE(*,*) 'Iterative solver terminated. code =', ipar(1) endif endif - end +end subroutine runrc !-----end-of-runrc !----------------------------------------------------------------------c ! S P A R S K I T c @@ -3921,21 +3921,21 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! ! initialize nonzero indicator array. ! - do 1 j=1,n + do j=1,n jw(n+j) = 0 - 1 continue + end do !----------------------------------------------------------------------- ! beginning of main loop. !----------------------------------------------------------------------- - do 500 ii = 1, n + do ii = 1, n j1 = ia(ii) j2 = ia(ii+1) - 1 tnorm = 0.0d0 - do 501 k=j1,j2 + do k=j1,j2 tnorm = tnorm+abs(a(k)) - 501 continue + end do if (abs(tnorm) .lt. tiny(1.)) goto 999 tnorm = tnorm/real(j2-j1+1) @@ -3948,7 +3948,7 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) w(ii) = 0.0 jw(n+ii) = ii ! - do 170 j = j1, j2 + do j = j1, j2 k = ja(j) t = a(j) if (k .lt. ii) then @@ -3965,7 +3965,7 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) w(jpos) = t jw(n+k) = jpos endif - 170 continue + end do jj = 0 lenn = 0 ! @@ -3982,12 +3982,12 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! ! determine smallest column index ! - do 151 j=jj+1,lenl + do j=jj+1,lenl if (jw(j) .lt. jrow) then jrow = jw(j) k = j endif - 151 continue + end do ! if (k .ne. jj) then ! exchange in jw @@ -4014,7 +4014,7 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! ! combine current row and row jrow ! - do 203 k = ju(jrow), jlu(jrow+1)-1 + do k = ju(jrow), jlu(jrow+1)-1 s = fact*alu(k) j = jlu(k) jpos = jw(n+j) @@ -4059,7 +4059,7 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) w(jpos) = w(jpos) - s endif endif - 203 continue + end do ! ! store this pivot element -- (from left to right -- no danger of ! overlap with the working elements in L (pivots). @@ -4072,9 +4072,9 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! ! reset double-pointer to zero (U-part) ! - do 308 k=1, lenu + do k=1, lenu jw(n+jw(ii+k-1)) = 0 - 308 continue + end do ! ! update L-matrix ! @@ -4087,12 +4087,12 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! ! store L-part ! - do 204 k=1, lenn + do k=1, lenn if (ju0 .gt. iwk) goto 996 alu(ju0) = w(k) jlu(ju0) = jw(k) ju0 = ju0+1 - 204 continue + end do ! ! save pointer to beginning of row ii of U ! @@ -4117,12 +4117,12 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) ! t = abs(w(ii)) if (lenn + ju0 .gt. iwk) goto 997 - do 302 k=ii+1,ii+lenn-1 + do k=ii+1,ii+lenn-1 jlu(ju0) = jw(k) alu(ju0) = w(k) t = t + abs(w(k) ) ju0 = ju0+1 - 302 continue + end do ! ! store inverse of diagonal element of u ! @@ -4137,7 +4137,7 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) !----------------------------------------------------------------------- ! end main loop !----------------------------------------------------------------------- - 500 continue + end do ierr = 0 return ! @@ -4167,12 +4167,12 @@ subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr) return !----------------end-of-ilut-------------------------------------------- !----------------------------------------------------------------------- - end +end subroutine ilut !---------------------------------------------------------------------- ! subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ipoint1, ipoint2, ierr) subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) - implicit real*8 (a-h,o-z) + !implicit real*8 (a-h,o-z) real*8 a(*), alu(*), tl integer n, ju0, ii, jj, i, j, jcol, js, jf, jm, jrow, jw, ierr integer ja(*), ia(*), ju(*), jlu(*), iw(n) @@ -4229,7 +4229,7 @@ subroutine ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr) ! zero pivot : 600 ierr = ii return - end +end subroutine ilu0 !----------------------------------------------------------------------- ! subroutine pgmres(n, im, rhs, sol, eps, maxits, ierr) ! subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, ierr) @@ -4485,7 +4485,7 @@ subroutine pgmres(n, im, rhs, sol, eps, maxits, aspar, nnz, ia, ja, alu, jlu, ju ierr = -1 return !--------------------------------------------------------------------- - end +end subroutine pgmres !----------------------------------------------------------------------- !----------------------------------------------------------------------- @@ -4539,7 +4539,7 @@ DOUBLE PRECISION FUNCTION DNRM2(N,X) ! auxiliary routine: ! CALL DLASSQ( N, X, SCALE, SSQ ) ! - DO 10 IX = 1,1 + (N-1) + DO IX = 1,1 + (N-1) IF (X(IX).NE.ZERO) THEN ABSXI = ABS(X(IX)) IF (SCALE.LT.ABSXI) THEN @@ -4549,7 +4549,7 @@ DOUBLE PRECISION FUNCTION DNRM2(N,X) SSQ = SSQ + (ABSXI/SCALE)**2 END IF END IF - 10 CONTINUE + end do NORM = SCALE*SQRT(SSQ) END IF ! @@ -4558,7 +4558,7 @@ DOUBLE PRECISION FUNCTION DNRM2(N,X) ! ! End of DNRM2. ! - END +END function dnrm2 !----------------------------------------------------------------------- SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ ) @@ -4603,7 +4603,7 @@ SUBROUTINE DLASSQ( N, X, SCALE, SUMSQ ) END DO END IF RETURN - END +END SUBROUTINE DLASSQ !------------------------------------------------------------------------- double precision function ddot(n,dx,dy) @@ -4621,18 +4621,18 @@ double precision function ddot(n,dx,dy) 20 m = mod(n,5) if( m .eq. 0 ) go to 40 - do 30 i = 1,m + do i = 1,m dtemp = dtemp + dx(i)*dy(i) - 30 continue + end do if( n .lt. 5 ) go to 60 40 mp1 = m + 1 - do 50 i = mp1,n,5 + do i = mp1,n,5 dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + & & dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue + end do 60 ddot = dtemp return - end +end function ddot !---------------------------------------------------------------------- subroutine daxpy(n,da,dx,incx,dy,incy) ! @@ -4654,11 +4654,11 @@ subroutine daxpy(n,da,dx,incx,dy,incy) iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n + do i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy - 10 continue + end do return ! ! code for both increments equal to 1 @@ -4668,16 +4668,16 @@ subroutine daxpy(n,da,dx,incx,dy,incy) ! 20 m = mod(n,4) if( m .eq. 0 ) go to 40 - do 30 i = 1,m + do i = 1,m dy(i) = dy(i) + da*dx(i) - 30 continue + end do if( n .lt. 4 ) return 40 mp1 = m + 1 - do 50 i = mp1,n,4 + do i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue + end do return - end +end subroutine daxpy diff --git a/model/src/w3servmd.F90 b/model/src/w3servmd.F90 index a9ca65826..a947ac6f3 100644 --- a/model/src/w3servmd.F90 +++ b/model/src/w3servmd.F90 @@ -393,11 +393,11 @@ SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) !/ !/ ------------------------------------------------------------------- / !/ - DO 100, ISEA=1, NSEA + DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) XY(IX,IY) = S(ISEA) - 100 CONTINUE + end do !/ !/ End of W3S2XY ----------------------------------------------------- / !/ @@ -511,7 +511,7 @@ REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) !/ !/ End of NEXTLN ----------------------------------------------------- / !/ - END FUNCTION + END FUNCTION EJ5P !/ ------------------------------------------------------------------- / REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) !/ @@ -589,7 +589,7 @@ REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) !/ !/ End of NEXTLN ----------------------------------------------------- / !/ - END FUNCTION + END FUNCTION DIST_SPHERE !/ ------------------------------------------------------------------- / !/ ------------------------------------------------------------------- / @@ -1635,9 +1635,9 @@ SUBROUTINE SSORT1 (X, Y, N, KFLAG) ! Alter array X to get decreasing order if needed ! IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN + DO I=1,NN X(I) = -X(I) - 10 CONTINUE + end do ENDIF ! IF (KK .EQ. 2) GO TO 100 @@ -1871,9 +1871,9 @@ SUBROUTINE SSORT1 (X, Y, N, KFLAG) ! Clean up ! 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN + DO I=1,NN X(I) = -X(I) - 200 CONTINUE + end do ENDIF RETURN END SUBROUTINE SSORT1 diff --git a/model/src/w3sic3md.F90 b/model/src/w3sic3md.F90 index 07751eef2..b71419eda 100644 --- a/model/src/w3sic3md.F90 +++ b/model/src/w3sic3md.F90 @@ -2535,7 +2535,7 @@ SUBROUTINE SMOOTH_K(WN_R,WN_I,SIGMA,N,SWITCHID) (SIGMA(I-1)-SIGMA(I-2))*(SIGMA(I)-SIGMA(I-1)) ENDIF RETURN - END SUBROUTINE + END SUBROUTINE SMOOTH_K !/ ------------------------------------------------------------------- / diff --git a/model/src/w3snl4md.F90 b/model/src/w3snl4md.F90 index 0a85e38ab..a19dca515 100644 --- a/model/src/w3snl4md.F90 +++ b/model/src/w3snl4md.F90 @@ -432,7 +432,7 @@ SUBROUTINE INSNL4 !! ================================================================ !! !! - do 29 nd = 1,ndep + do nd = 1,ndep !! !! !!-4b For given new depth dep2 = dep_tbl(nd) calculate @@ -486,12 +486,12 @@ SUBROUTINE INSNL4 dwka = ( wka2(2) - wkfnc(frqa(1)/dfrq,dep2) ) / 2. pha2(1) = wka2(1)*dwka*ainc !! - do 23 irng=2,nrng-1 + do irng=2,nrng-1 !! Below: variable dwka = dk centered at irng (between irng-1 & irng+1) !! and computed pha2(irng) = k*dk*dtheta at irng dwka = ( wka2(irng+1) - wka2(irng-1) ) / 2. pha2(irng) = wka2(irng)*dwka*ainc - 23 continue + end do !! !! Below: variable dwka = dk centered at nrng (between nrng-1 & nrng+1) !! and computed pha2(nrng) = k*dk*dtheta at nrng @@ -509,7 +509,7 @@ SUBROUTINE INSNL4 !! ============================================================== !! !! - 29 continue !* End do 29 nd = 1,ndep + end do ! nd = 1,ndep !! ---------------------------------------------------------------- !! ================================================================ !! @@ -1077,27 +1077,26 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! to 2D Energy Density spectrum "ef2(theta,f)" & reverse indices !! ==> ef2(f,theta) = A(theta,k) * 2*pi*oma(f)/cga(f) !! ------------------------------------------------------------------ - do 32 irng=1,nrng + do irng=1,nrng fac = twopi*oma(irng)/cga(irng) - do 31 iang=1,nang + do iang=1,nang ef2(irng,iang) = A(iang,irng) * fac - 31 continue - 32 continue + end do + end do !! ------------------------------------------------------------------ !! !! !!*i5 Calculte the 1D Energy Density "ef1(f)" !! ------------------------------------------------------------------ - do 42 irng=1,nrng + do irng=1,nrng sum1 = 0.0 - do 41 iang=1,nang + do iang=1,nang sum1 = sum1 + ef2(irng,iang) - 41 continue + end do ef1(irng) = sum1 * ainc - 42 continue + end do !! ------------------------------------------------------------------ !! ================================================================== -!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !!------------------------------------------------------------------------------ !!============================================================================== !! @@ -1146,7 +1145,7 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) e1max = 0.0 npeaks = 0 !! Look in the freq range that works for TSA call (see condition below) - do 43 irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< + do irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< !! Pick the 1st local abs. max in [2,nrng-1] using (ef1(irng).gt.e1max) !! so that if 2 equal adj. peaks are found it will pick the 1st e1max !! encountered (i.e. the lower freq. one) @@ -1159,7 +1158,7 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) e1max = ef1(npk) !* update e1max npeaks = 1 endif - 43 continue + end do !! ------------------------------------------------------------------ !! !!B if a 1st peak is not found (npeaks=0 & e1max=0.0 < eps) or @@ -1187,7 +1186,7 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) e1max2 = 0.0 !! Again look in the freq range that is in line with TSA min condition !! and find the 2nd highest peak with eps < e1max2 < e1max - do 45 irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< + do irng=2,nrng-1 !* last peak loc. is at nrng-1 <<<<< !! Pick the 2nd local abs. max in [2,nrng-1] that is at least 'nsep' !! bins away from the 1st peak using (ef1(irng).ge.e1max2) so that !! if 2 equal adj. peaks are found it will pick the 2nd e1max2 @@ -1201,7 +1200,7 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) e1max2 = ef1(npk2) !* update e1max2 npeaks = 2 endif - 45 continue + end do !! ------------------------------------------------------------------ !! !!B if a 2nd peak is not found (npeaks=1 & e1max2=0.0 < eps) @@ -1243,7 +1242,6 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) 200 continue !! ------------------------------------------------------------ !!op2 !! ================================================================== -!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! !! Bash; With the new "optsa2" you are allowed one call (if 1 peak) @@ -1293,7 +1291,7 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! ================================================================ !! !!-3 Remove the step like jump (if exists) in dens1() between nfs & nfs+1 - do 440 iang=1,nang + do iang=1,nang sumd1 = dens1(nfs,iang) + dens2(nfs,iang) !* sum at nfs sumd2 = dens1(nfs+1,iang) + dens2(nfs+1,iang) !* sum at nfs+1 !! @@ -1311,11 +1309,10 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! recalculate dens2(nfs,iang) & dens2(nfs+1,iang) dens2(nfs,iang) = sumd1 - densat1 ! dens2 at nfs dens2(nfs+1,iang) = sumd2 - densat2 ! dens2 at nfs+1 - 440 continue + end do !! endif !! if ( npeaks.eq.2 ) !! ================================================================== -!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! !! @@ -1340,15 +1337,15 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! !! Pack results in proper format ---------------------------------- * !! S() & D() arrays are to be returned to WW3 in (k,theta) space - do 52 irng=1,nrng - do 51 iang=1,nang + do irng=1,nrng + do iang=1,nang !! Convert the Norm. (in k) Polar tsa(k,theta) to Polar S(theta,k) !! and reverse indices back to (iang,irng) as in WW3 S(iang,irng) = tsa(irng,iang) * wka(irng) !* <============= D(iang,irng) = diag(irng,iang) !! --------------------------- - 51 continue - 52 continue + end do + end do !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! !! @@ -1365,15 +1362,15 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) !! !! Pack results in proper format ---------------------------------- * !! S() & D() arrays are to be returned to WW3 in (k,theta) space - do 54 irng=1,nrng - do 53 iang=1,nang + do irng=1,nrng + do iang=1,nang !! Convert the Norm. (in k) Polar fbi(k,theta) to Polar S(theta,k) !! and reverse indices back to (iang,irng) as in WW3 S(iang,irng) = fbi(irng,iang) * wka(irng) !* <============= D(iang,irng) = diag2(irng,iang) !! -------------------------------- - 53 continue - 54 continue + end do + end do !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! else @@ -1393,7 +1390,6 @@ SUBROUTINE W3SNL4 ( A, CG, WN, DEPTH, S, D ) END SUBROUTINE W3SNL4 !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE gridsetr ( dep, wka1, cgnrng1 ) @@ -1848,13 +1844,13 @@ SUBROUTINE gridsetr ( dep, wka1, cgnrng1 ) jref4(ipt,kang,izz) = i !mpc jref4(ipt,kang,izz) = MOD(i,nang) !* is this better that the above two lines? !! - 50 continue !* end of ipt loop +50 end do !* end of ipt loop !! - 40 continue !* end of kang loop +40 end do !* end of kang loop !! - 30 continue !* end of krng loop +30 end do !* end of krng loop !! - 20 continue !* end of irng loop +20 end do !* end of irng loop !! ------------------------------------------------------------------ !! ================================================================== !! @@ -1863,7 +1859,6 @@ SUBROUTINE gridsetr ( dep, wka1, cgnrng1 ) END SUBROUTINE gridsetr !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) @@ -2062,7 +2057,7 @@ SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) halfp = 0.5*p !! !! - do 10 n=np2p1,npts !* for npts = 30 + do n=np2p1,npts !* for npts = 30 !! !* n = 16 --> 30 !! !b b = 0.5 * db + float(n-np2p1) * db @@ -2089,7 +2084,7 @@ SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) wk4y(m) = wk2y(m) - py ds(m) = db !! - 10 continue + end do ! do n=np2p1,npts !! ------------------------------------------------------------------ !! ================================================================== !! @@ -2098,7 +2093,6 @@ SUBROUTINE shloxr ( dep, wk1x,wk1y, wk3x,wk3y ) END SUBROUTINE shloxr !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) @@ -2364,7 +2358,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) rnew1 = (t1 + t2 + t3) / (t*t) !! !! - do 10 n=1,4 + do n=1,4 rold2 = rold1 + 0.1 tp = tanh(rold2 * p) tm = tanh((1.-rold2) * p) @@ -2379,14 +2373,14 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) end if rold1 = rold2 rnew1 = rnew2 - 10 continue + end do ! do n=1,4 rold = 0.9 !* default if not otherwise found 11 continue !! ------------------------------------------------------------------ !! !! !! iterative replacement search for rmin - do 20 n=1,50 + do n=1,50 tp = tanh(rold * p) tm = tanh((1.-rold) * p) t = tp + tm @@ -2399,7 +2393,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) go to 21 end if rold = 0.5 * (rold + rnew) - 20 continue + end do ierr_gr = ierr_gr + 1 !* set 1's flag in ierr_gr if no convergence rmin = rnew 21 continue @@ -2455,7 +2449,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) !! -----------------------------------------------------------------# !! rold = 1.0 - do 30 n=1,200 + do n=1,200 rold = rold + 10. tp = tanh(rold * p) tm = tanh((rold-1.) * p) @@ -2467,7 +2461,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) rold = rold - 10. go to 31 end if - 30 continue + end do ierr_gr = ierr_gr + 10 !* set 10's place in ierr_gr if no sol'n 31 continue !! ------------------------------------------------------------------ @@ -2475,9 +2469,9 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) !! !! successive decimation search to refine rmax dr = 10. - do 40 nplace=1,6 + do nplace=1,6 dr = dr/10. - do 50 n=1,10 + do n=1,10 rold = rold + dr tp = tanh(rold * p) tm = tanh((rold-1.) * p) @@ -2489,9 +2483,9 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) rold = rold - dr go to 51 end if - 50 continue + end do 51 continue - 40 continue + end do !! rmax = rold !! @@ -2553,7 +2547,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) dbqrtp = dble(qrtp) !! !! - do 60 np=2,npts/2 !* np = 2 --> 15 + do np=2,npts/2 !* np = 2 --> 15 !! cphi = cos(float(np-1)*dphi) dbz = dsqrt(dble(t1-t2*cphi)) @@ -2571,12 +2565,12 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) wate2 = 0.5d0 end if !! - do 70 n=1,25 + do n=1,25 cdthnew = dbt4 - dbt5 / ((dtanh(dbt6))**2) if ( dabs(cdthnew-cdthold) .lt. 0.0000001d0 ) go to 71 cdthold = wate1 * cdthnew + wate2 * cdthold dbt6 = dbp * dsqrt(dbt3-2.d0*dbz*cdthold) - 70 continue + end do ierr_gr = ierr_gr + 100 !* add to 100's place for every failure 71 continue !! @@ -2596,7 +2590,7 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) wk4x(nnp) = wk2x(nnp) - pxod wk4y(nnp) = wk2y(nnp) - pyod !! - 60 continue + end do ! do np=2,npts/2 !! ------------------------------------------------------------------ !! !! @@ -2612,12 +2606,12 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) !! ds1 = sqrt((wk2x(2)-wk2x(1))**2+(wk2y(2)-wk2y(1))**2) ds(1) = ds1 - do 80 np=3,npts/2+1 + do np=3,npts/2+1 ds2 = sqrt((wk2x(np)-wk2x(np-1))**2+(wk2y(np)-wk2y(np-1))**2) ds(np-1) = 0.5*(ds1+ds2) ds(npts-np+3) = ds(np-1) ds1 = ds2 - 80 continue + end do ds(npts/2+1) = ds2 !! ------------------------------------------------------------------ !! ================================================================== @@ -2629,7 +2623,6 @@ SUBROUTINE shlocr ( dep, wk1x,wk1y, wk3x,wk3y ) END SUBROUTINE shlocr !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & @@ -2788,7 +2781,7 @@ SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & !!ini--- !! ------------------------------------------------------------------ !! - do 10 ipass=1,3 + do ipass=1,3 !p1 if (ipass .eq. 1) then !* initial pass (+1,+1,-1) s1 = 1.d0 @@ -2967,7 +2960,7 @@ SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & !! scple = scple + t1 + t2 + t3 + t4 + t5 !! - 10 continue !! end do 10 ipass=1,3 + end do ! do ipass=1,3 !! ------------------------------------------------------------------ !! ================================================================== !! @@ -2991,7 +2984,6 @@ SUBROUTINE cplshr ( w1x0,w1y0, w2x0,w2y0, w3x0,w3y0, & END SUBROUTINE cplshr !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) @@ -3205,18 +3197,18 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !! !!* Convert 2D Energy Density ef2(f,theta) !! to 2D Polar Action Density act2d(k,theta) Norm. (in k) - do 25 irng=nrmn,nrmx + do irng=nrmn,nrmx fac = cga(irng)/(twopi*oma(irng)*wka(irng)) - do 24 iang=1,nang + do iang=1,nang act2d(irng,iang) = ef2(irng,iang) * fac - 24 continue + end do !! !!* Convert ef1(f) to fk(k); both are 1d Energy Density fk(irng) = cga(irng)*ef1(irng)/twopi !* fk(k) energy !! !!* Normalize the 1d wavenumber Energy Density fk(k) to give fknrm(k) fknrm(irng) = fk(irng)*wka(irng)**2.5 !* fknrm(k) = Norm. fk(k) - 25 continue + end do !! ------------------------------------------------------------------ !! !! @@ -3239,7 +3231,7 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !eq sum1 = sum1 + fknrm(irng) !eq neq = neq + 1 !eq endif -! 26 continue +! 26 end do !eq beta = sum1 / neq !eq gam = fknrm(npk) / beta !!eq--- @@ -3250,9 +3242,9 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !!eq--- !! ------------------------------------------------------------------ !! - do 226 irng=nrmn,nrmx + do irng=nrmn,nrmx fknrm(irng) = fknrm(irng) / beta - 226 continue + end do !! ================================================================== !! !! @@ -3264,15 +3256,15 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !! Note: n1, n2 spans half circle (from -pi/2 to +pi/2 going through 0.) !p2 n1 = -nang/4 + 1 !p2 n2 = nang/4 + 1 -!p2 do 16 m=1,16 +!p2 do m=1,16 !p2 sum1 = 0. -!p2 do 15 iang=n1,n2 +!p2 do iang=n1,n2 !p2 ii = iang !p2 if ( iang .lt. 1 ) ii = iang + nang !p2 sum1 = sum1 + cosan(ii)**m -! 15 continue +! end do !p2 q(m) = 1./(sum1*ainc) -! 16 continue +! end do !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! !! Find peak direction "maxang" in ef2() at "npk" the peak in ef1() @@ -3281,36 +3273,36 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !! in "maxang" location causing the 2D Snl to lose symmetry !p2 emax = 0. !p2 maxang = 0 -!p2 do 27 iang=1,nang +!p2 do iang=1,nang !p2 if ( ef2(npk,iang).gt.emax ) then !p2 emax = ef2(npk,iang) !p2 maxang = iang !* in [1,nang] !p2 endif -! 27 continue +! end do !p2 y = ef2(npk,maxang)/ef1(npk) !* Bash; Energy Spread !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! !! Compare value of peak with q-array for closest fit to cos()**m at peak !p2 mm = 1 !p2 qmin = abs(q(1)-y) -!p2 do 28 m=2,16 +!p2 do m=2,16 !p2 adif = abs(q(m)-y) !p2 if ( adif.lt.qmin ) then !p2 qmin = adif !p2 mm = m !p2 endif -! 28 continue +! end do !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! !p2 nn1 = maxang - nang/4 !* nn1 in [-8, 27], -ve/+ve (incl. 0) !p2 nn2 = maxang + nang/4 !* nn2 in [10, 45], all +ve (no 0) -!p2 do 29 iang=nn1,nn2 !* Bash; nn1 -> nn2 covers half circle +!p2 do iang=nn1,nn2 !* Bash; nn1 -> nn2 covers half circle !p2 ii = iang !* ii always in range [1,nang] !p2 if ( ii .lt. 1 ) ii = ii + nang !* "" !p2 if ( ii .gt. nang ) ii = ii - nang !* "" !p2 idif = iabs(maxang-iang) + 1 !* =10,9,..,2,1,2,..,9,10 !p2 psi2(ii) = q(mm) * cos(angl(idif))**mm !* Normalized psi2 distr. -! 29 continue +! end do !!p2--- !! ================================================================== !! @@ -3325,13 +3317,13 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !! Note: n1, n2 spans half circle (from 0 to +pi) !p3 n1 = 1 !p3 n2 = nang/2 + 1 -!p3 do 36 m=1,16 +!p3 do m=1,16 !p3 sum1 = 0. -!p3 do 35 iang=n1,n2 +!p3 do iang=n1,n2 !p3 sum1 = sum1 + sinan(iang)**m -! 35 continue +! end do !p3 q(m) = 1./(sum1*ainc) -! 36 continue +! end do !!p3--- !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! @@ -3384,13 +3376,13 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) !! the 2D Snl, now with better symmetry, didn't always have the side lobes. !p3 mm = 1 !p3 qmin = abs(q(1)-y) -!p3 do 38 m=2,16 +!p3 do m=2,16 !p3 adif = abs(q(m)-y) !p3 if ( adif.lt.qmin ) then !p3 qmin = adif !p3 mm = m !p3 endif -! 38 continue +! end do !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! !! Final step, use 'mm' for sin()**mm @@ -3414,9 +3406,9 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) n1 = 1 n2 = nang/2 + 1 !p4 sum1 = 0. -!p4 do 39 iang=n1,n2 +!p4 do iang=n1,n2 !p4 sum1 = sum1 + sinan(iang)**4 -! 39 continue +! end do !p4 q4 = 1.0/(sum1*ainc) !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! @@ -3441,7 +3433,7 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) fdenp = gam * beta / wka(npk)**2.5 !! !! - do 40 irng=nrmn,nrmx + do irng=nrmn,nrmx fr = frqa(irng) / fpk if ( fr.le.1.0001 ) then if ( fr.ge.0.85 ) then @@ -3459,12 +3451,12 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) bscl1(irng) = fkscl1(irng)/oma(irng) endif !! - do 41 iang=1,nang + do iang=1,nang ddd = bscl1(irng) * psi2(iang) / wka(irng) !* large-scale dens1(irng,iang) = ddd !* large-scale dens2(irng,iang) = act2d(irng,iang) - ddd !* small-scale - 41 continue - 40 continue + end do + end do ! do irng=nrmn,nrmx !! ------------------------------------------------------------------ !! ================================================================== !! @@ -3473,7 +3465,6 @@ SUBROUTINE optsa2 ( nrmn,nrmx, npk,fpk, nbins, wka, cga ) END SUBROUTINE optsa2 !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE snlr_fbi ( pha, ialt ) @@ -3988,7 +3979,7 @@ SUBROUTINE snlr_fbi ( pha, ialt ) !! ======================================================== !! !! - 90 continue !* end of ipt (locus) loop +90 end do !* end of ipt (locus) loop !! ---------------------------------------------------------- !! !! @@ -4042,13 +4033,13 @@ SUBROUTINE snlr_fbi ( pha, ialt ) diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) !! ---------------------------------------------------------- !! - 80 continue !* end of kang loop +80 end do !* end of kang loop !! - 70 continue !* end of krng loop +70 end do !* end of krng loop !! - 60 continue !* end of iang loop +60 end do !* end of iang loop !! - 50 continue !* end of irng loop +50 end do !* end of irng loop !!------------------------------------------------------------------------------ !!============================================================================== !! @@ -4088,7 +4079,6 @@ SUBROUTINE snlr_fbi ( pha, ialt ) END SUBROUTINE snlr_fbi !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE snlr_tsa ( pha, ialt ) @@ -4603,7 +4593,7 @@ SUBROUTINE snlr_tsa ( pha, ialt ) !! ======================================================== !! !! - 90 continue !* end of ipt (locus) loop +90 end do !* end of ipt (locus) loop !! ---------------------------------------------------------- !! !! @@ -4657,13 +4647,13 @@ SUBROUTINE snlr_tsa ( pha, ialt ) !fbi diag2(krng,kang) = diag2(krng,kang) - diag2k3*pha(irng) !! ---------------------------------------------------------- !! - 80 continue !* end of kang loop +80 end do !* end of kang loop !! - 70 continue !* end of krng loop +70 end do !* end of krng loop !! - 60 continue !* end of iang loop +60 end do !* end of iang loop !! - 50 continue !* end of irng loop +50 end do !* end of irng loop !!------------------------------------------------------------------------------ !!============================================================================== !! @@ -4703,7 +4693,6 @@ SUBROUTINE snlr_tsa ( pha, ialt ) END SUBROUTINE snlr_tsa !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SUBROUTINE interp2 ( X ) @@ -4820,26 +4809,26 @@ SUBROUTINE interp2 ( X ) !! !!-1a For every calculated iang (1,3,5,..,nang-1=35) !! fill in missing irng's (2,4,6,..,nrng-1=34) - do 12 iang=1,nang-1,2 !* = 1,3,5,...,nang-1=35 - do 11 irng=2,nrng-1,2 !* = 2,4,6,...,nrng-1=34 + do iang=1,nang-1,2 !* = 1,3,5,...,nang-1=35 + do irng=2,nrng-1,2 !* = 2,4,6,...,nrng-1=34 X(irng,iang) = 0.5 * ( X(irng-1,iang) + X(irng+1,iang) ) - 11 continue - 12 continue + end do + end do !! ------------------------------------------------------------------ !! !!-1b Now, for every irng (1,2,3,..,nrng =35) !! fill missing iang's (2,4,6,..,nang-2=34) - do 14 irng=1,nrng !* 1,2,3,..,nrng =35 - do 13 iang=2,nang-2,2 !* 2,4,6,..,nang-2=34 + do irng=1,nrng !* 1,2,3,..,nrng =35 + do iang=2,nang-2,2 !* 2,4,6,..,nang-2=34 X(irng,iang) = 0.5 * ( X(irng,iang-1) + X(irng,iang+1) ) - 13 continue - 14 continue + end do + end do !! ------------------------------------------------------------------ !! !!-1c for iang = nang (special case since nang is an even number) - do 15 irng=1,nrng + do irng=1,nrng X(irng,nang) = 0.5 * ( X(irng,nang-1) + X(irng,1) ) - 15 continue + end do !! ------------------------------------------------------------------ !! ================================================================== !! @@ -4857,13 +4846,13 @@ SUBROUTINE interp2 ( X ) !!-2a Smoothing the interior [2;nrng-1] x [2:nang-1] !!- Using 9 points averaged with equal weights. !!- Here use the dummy array so we don't spoil the original array. - do 22 irng=2,nrng-1 - do 21 iang=2,nang-1 + do irng=2,nrng-1 + do iang=2,nang-1 Y(irng,iang)=(X(irng-1,iang-1)+X(irng-1,iang)+X(irng-1,iang+1) + & X(irng, iang-1)+X(irng, iang)+X(irng, iang+1) + & X(irng+1,iang-1)+X(irng+1,iang)+X(irng+1,iang+1))/9. - 21 continue - 22 continue + end do + end do !! ------------------------------------------------------------------ !! ================================================================== !! @@ -4872,20 +4861,20 @@ SUBROUTINE interp2 ( X ) !! !!-3a Smooth line at iang = 1 (special case) !!- Using 9 points averaged with equal weights. - do 31 irng=2,nrng-1 + do irng=2,nrng-1 Y(irng, 1) = (X(irng-1,nang) + X(irng-1, 1) + X(irng-1, 2) + & X(irng, nang) + X(irng, 1) + X(irng, 2) + & X(irng+1,nang) + X(irng+1, 1) + X(irng+1, 2) )/9. - 31 continue + end do !! ------------------------------------------------------------------ !! !!-3b Smooth line at iang = nang (special case) !!- Using 9 points averaged with equal weights. - do 32 irng=2,nrng-1 + do irng=2,nrng-1 Y(irng,nang)=(X(irng-1,nang-1) +X(irng-1,nang) +X(irng-1,1) + & X(irng, nang-1) +X(irng, nang) +X(irng, 1) + & X(irng+1,nang-1) +X(irng+1,nang) +X(irng+1,1))/9. - 32 continue + end do !! ------------------------------------------------------------------ !! ================================================================== !! @@ -4894,18 +4883,18 @@ SUBROUTINE interp2 ( X ) !! !!-4a Smooth col. at irng = 1 (low frq. can be skipped) !!- Using 6 points averaged with equal weights. - do 33 iang=2,nang-1 + do iang=2,nang-1 Y(1,iang) = (X(1,iang-1) + X(1,iang) + X(1,iang+1) + & X(2,iang-1) + X(2,iang) + X(2,iang+1) )/6. - 33 continue + end do !! ------------------------------------------------------------------ !! !!-4b Smooth col. at irng = nrng (high frq. can be skipped) !!- Using 6 points averaged with equal weights. - do 34 iang=2,nang-1 + do iang=2,nang-1 Y(nrng,iang)=(X(nrng-1,iang-1)+X(nrng-1,iang)+X(nrng-1,iang+1)+ & X(nrng, iang-1)+X(nrng, iang)+X(nrng, iang+1) )/6. - 34 continue + end do !! ------------------------------------------------------------------ !! ================================================================== !! @@ -4943,11 +4932,11 @@ SUBROUTINE interp2 ( X ) !!ini--- !! !!-6b Dump smoothed array Y(:,:) into X(:,:) to be returned - do 52 iang=1,nang - do 51 irng=1,nrng + do iang=1,nang + do irng=1,nrng X(irng,iang) = Y(irng,iang) - 51 continue - 52 continue + end do + end do !! Bash; can simplify in one line !b X(1:nrng, 1:nang) = Y(1:nrng, 1:nang) !! ------------------------------------------------------------------ @@ -4963,7 +4952,6 @@ SUBROUTINE interp2 ( X ) END SUBROUTINE interp2 !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL FUNCTION wkfnc ( f, dep ) @@ -5052,7 +5040,6 @@ REAL FUNCTION wkfnc ( f, dep ) END FUNCTION wkfnc !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - REAL FUNCTION cgfnc ( f, dep, cvel ) @@ -5131,10 +5118,8 @@ REAL FUNCTION cgfnc ( f, dep, cvel ) END FUNCTION cgfnc !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ !! !! END MODULE W3SNL4MD !! !!============================================================================== -!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/model/src/w3src3md.F90 b/model/src/w3src3md.F90 index 886b7efd8..91f7db440 100644 --- a/model/src/w3src3md.F90 +++ b/model/src/w3src3md.F90 @@ -288,7 +288,7 @@ SUBROUTINE W3SPR3 (A, CG, WN, EMEAN, FMEAN, FMEANS, WNMEAN, & !/ !/ End of W3SPR3 ----------------------------------------------------- / !/ - END SUBROUTINE + END SUBROUTINE W3SPR3 !/ ------------------------------------------------------------------- / SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & TAUWX, TAUWY, TAUWNX, TAUWNY, ICE, S, D, LLWS, IX, IY) @@ -626,7 +626,7 @@ SUBROUTINE W3SIN3 (A, CG, K, U, USTAR, DRAT, AS, USDIR, Z0, CD, & !/ !/ End of W3SIN3 ----------------------------------------------------- / !/ - END SUBROUTINE + END SUBROUTINE W3SIN3 !/ ------------------------------------------------------------------- / SUBROUTINE INSIN3 !/ diff --git a/model/src/w3srcemd.F90 b/model/src/w3srcemd.F90 index f5b67b21e..fd9a12eea 100644 --- a/model/src/w3srcemd.F90 +++ b/model/src/w3srcemd.F90 @@ -2384,7 +2384,7 @@ SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3(SPEC, VS, VD) DO IS=1,NSPEC VD(IS) = MIN(0., VD(IS)) END DO - END SUBROUTINE + END SUBROUTINE SIGN_VSD_SEMI_IMPLICIT_WW3 !/ ------------------------------------------------------------------- / SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) !/ @@ -2461,7 +2461,7 @@ SUBROUTINE SIGN_VSD_PATANKAR_WW3(SPEC, VS, VD) VD(IS) = MIN(0., VD(IS)) VS(IS) = MAX(0., VS(IS)) END DO - END SUBROUTINE + END SUBROUTINE SIGN_VSD_PATANKAR_WW3 !/ !/ End of module W3SRCEMD -------------------------------------------- / !/ diff --git a/model/src/w3strkmd.F90 b/model/src/w3strkmd.F90 index dfd170de2..7967c2417 100644 --- a/model/src/w3strkmd.F90 +++ b/model/src/w3strkmd.F90 @@ -1408,7 +1408,12 @@ SUBROUTINE waveTracking_NWS_V2 (intype ,tmax , & WRITE(20,*) '*** SIZE(sysA(1:tsA)%sys) at end of time step', & tsA,':' WRITE(20,*) SIZE(sysA(tsA)%sys) +#ifdef W3_SHRD END DO +#endif +#ifdef W3_MPI + END DO +#endif #ifdef W3_MPI CALL MPI_Barrier(MPI_COMM_WORLD,IERR) diff --git a/model/src/w3tidemd.F90 b/model/src/w3tidemd.F90 index e24254786..7d1413e62 100644 --- a/model/src/w3tidemd.F90 +++ b/model/src/w3tidemd.F90 @@ -998,23 +998,23 @@ SUBROUTINE dsvbksb(u,w,v,m,n,mp,np,b,x) PARAMETER (NMAX=500) INTEGER i,j,jj DOUBLE PRECISION s,tmp(NMAX) - do 12 j=1,n + do j=1,n s=0.0d0 IF (w(j).ne.0.0d0)then - do 11 i=1,m + do i=1,m s=s+u(i,j)*b(i) -11 continue + end do s=s/w(j) endif tmp(j)=s -12 continue - do 14 j=1,n + end do + do j=1,n s=0.0d0 - do 13 jj=1,n + do jj=1,n s=s+v(j,jj)*tmp(jj) -13 continue + end do x(j)=s -14 continue + end do return END SUBROUTINE dsvbksb @@ -1031,7 +1031,7 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) g=0.0d0 scale=0.0d0 anorm=0.0d0 - do 25 i=1,n + do i=1,n l=i+1 rv1(i)=scale*g g=0.0d0 @@ -1073,100 +1073,100 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) s=0.0d0 scale=0.0d0 IF ((i.le.m).and.(i.ne.n))then - do 17 k=l,n + do k=l,n scale=scale+abs(a(i,k)) -17 continue + end do IF (scale.ne.0.0d0)then - do 18 k=l,n + do k=l,n a(i,k)=a(i,k)/scale s=s+a(i,k)*a(i,k) -18 continue + end do f=a(i,l) g=-sign(sqrt(s),f) h=f*g-s a(i,l)=f-g - do 19 k=l,n + do k=l,n rv1(k)=a(i,k)/h -19 continue - do 23 j=l,m + end do + do j=l,m s=0.0d0 - do 21 k=l,n + do k=l,n s=s+a(j,k)*a(i,k) -21 continue - do 22 k=l,n + end do + do k=l,n a(j,k)=a(j,k)+s*rv1(k) -22 continue -23 continue - do 24 k=l,n + end do + end do + do k=l,n a(i,k)=scale*a(i,k) -24 continue + end do endif endif anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) -25 continue - do 32 i=n,1,-1 + end do + do i=n,1,-1 IF (i.lt.n)then IF (g.ne.0.0d0)then - do 26 j=l,n + do j=l,n v(j,i)=(a(i,j)/a(i,l))/g -26 continue - do 29 j=l,n + end do + do j=l,n s=0.0d0 - do 27 k=l,n + do k=l,n s=s+a(i,k)*v(k,j) -27 continue - do 28 k=l,n + end do + do k=l,n v(k,j)=v(k,j)+s*v(k,i) -28 continue -29 continue + end do + end do endif - do 31 j=l,n + do j=l,n v(i,j)=0.0d0 v(j,i)=0.0d0 -31 continue + end do endif v(i,i)=1.0d0 g=rv1(i) l=i -32 continue - do 39 i=min(m,n),1,-1 + end do + do i=min(m,n),1,-1 l=i+1 g=w(i) - do 33 j=l,n + do j=l,n a(i,j)=0.0d0 -33 continue + end do IF (g.ne.0.0d0)then g=1.0d0/g - do 36 j=l,n + do j=l,n s=0.0d0 - do 34 k=l,m + do k=l,m s=s+a(k,i)*a(k,j) -34 continue + end do f=(s/a(i,i))*g - do 35 k=i,m + do k=i,m a(k,j)=a(k,j)+f*a(k,i) -35 continue -36 continue - do 37 j=i,m + end do + end do + do j=i,m a(j,i)=a(j,i)*g -37 continue + end do else - do 38 j= i,m + do j= i,m a(j,i)=0.0d0 -38 continue + end do endif a(i,i)=a(i,i)+1.0d0 -39 continue - do 49 k=n,1,-1 - do 48 its=1,30 - do 41 l=k,1,-1 + end do + do k=n,1,-1 + do its=1,30 + do l=k,1,-1 nm=l-1 IF ((abs(rv1(l))+anorm).eq.anorm) goto 2 IF ((abs(w(nm))+anorm).eq.anorm) goto 1 -41 continue + end do 1 c=0.0d0 s=1.0d0 - do 43 i=l,k + do i=l,k f=s*rv1(i) rv1(i)=c*rv1(i) IF ((abs(f)+anorm).eq.anorm) goto 2 @@ -1176,20 +1176,20 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) h=1.0d0/h c= (g*h) s=-(f*h) - do 42 j=1,m + do j=1,m y=a(j,nm) z=a(j,i) a(j,nm)=(y*c)+(z*s) a(j,i)=-(y*s)+(z*c) -42 continue -43 continue + end do + end do 2 z=w(k) IF (l.eq.k)then IF (z.lt.0.0d0)then w(k)=-z - do 44 j=1,n + do j=1,n v(j,k)=-v(j,k) -44 continue + end do endif goto 3 endif @@ -1207,7 +1207,7 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x c=1.0d0 s=1.0d0 - do 47 j=l,nm + do j=l,nm i=j+1 g=rv1(i) y=w(i) @@ -1221,12 +1221,12 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) g=-(x*s)+(g*c) h=y*s y=y*c - do 45 jj=1,n + do jj=1,n x=v(jj,j) z=v(jj,i) v(jj,j)= (x*c)+(z*s) v(jj,i)=-(x*s)+(z*c) -45 continue + end do z=dpythag(f,h) w(j)=z IF (z.ne.0.0d0)then @@ -1236,19 +1236,19 @@ SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) endif f= (c*g)+(s*y) x=-(s*g)+(c*y) - do 46 jj=1,m + do jj=1,m y=a(jj,j) z=a(jj,i) a(jj,j)= (y*c)+(z*s) a(jj,i)=-(y*s)+(z*c) -46 continue -47 continue + end do + end do rv1(l)=0.0d0 rv1(k)=f w(k)=x -48 continue + end do 3 continue -49 continue + end do return END SUBROUTINE dsvdcmp @@ -1774,7 +1774,7 @@ SUBROUTINE OPNVUF(filename) open(unit=KR,file=filename,status='old',form='formatted') JBASE=0 - DO 90 K=1,1000 + DO K=1,1000 READ(KR,60)TIDECON_ALLNAMES(K),II(K),JJ(K),KK(K),LL(K),MM(K),NN(K),SEMI(K), & NJ(K) 60 FORMAT(6X,A5,1X,6I3,F5.2,I4) @@ -1814,8 +1814,8 @@ SUBROUTINE OPNVUF(filename) READ(KR,80)(LDEL(J),MDEL(J),NDEL(J),PH(J),EE(J),IR(J),J=J1,JL) 80 FORMAT((11X,3(3I3,F4.2,F7.4,1X,I1,1X))) END IF -90 JBASE=JL - + JBASE=JL + end do 100 NTIDAL_CON=K-1 JLM=JL @@ -1832,14 +1832,15 @@ SUBROUTINE OPNVUF(filename) ! JBASE=0 K1=NTIDAL_CON+1 - DO 160 K=K1,1000 + DO K=K1,1000 J1=JBASE+1 J4=J1+3 READ(KR,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) 130 FORMAT(6X,A5,I1,2X,4(F5.2,A5,5X)) !WRITE(995,130)TIDECON_ALLNAMES(K),NJ(K),(COEF_CON(J),KONCO_CON(J),J=J1,J4) IF (TIDECON_ALLNAMES(K).eq.KBLANK) go to 170 -160 JBASE=JBASE+NJ(K) + JBASE=JBASE+NJ(K) + end do 170 NTOTAL_CON=K-1 @@ -1940,12 +1941,12 @@ SUBROUTINE SETVUF(hr,XLAT,ITIME) !* TING THE LUNAR TIME TAU. ! JBASE=0 - DO 210 K=1,NTIDAL_CON - do 209 l=1,TIDE_MF + DO K=1,NTIDAL_CON + do l=1,TIDE_MF IF (TIDECON_ALLNAMES(k).eq.TIDECON_NAME(l)) then indx(k)=l END IF -209 continue + end do VDBL=II(K)*TAU+JJ(K)*S+KK(K)*H+LL(K)*P+MM(K)*ENP+NN(K)*PP+SEMI(K) IV=VDBL IV=(IV/2)*2 @@ -1954,7 +1955,7 @@ SUBROUTINE SETVUF(hr,XLAT,ITIME) JL=JBASE+NJ(K) SUMC=1. SUMS=0. - DO 200 J=J1,JL + DO J=J1,JL ! !*********************************************************************** !* HERE THE SATELLITE AMPLITUDE RATIO ADJUSTMENT FOR LATITUDE IS MADE @@ -1971,11 +1972,12 @@ SUBROUTINE SETVUF(hr,XLAT,ITIME) UU=UUDBL-IUU SUMC=SUMC+RR*COS(UU*TWOPI) SUMS=SUMS+RR*SIN(UU*TWOPI) - 200 CONTINUE + end do F_ARG(K,ITIME)=SQRT(SUMC*SUMC+SUMS*SUMS) v_ARG(k,ITIME)=vv U_ARG(K,ITIME)=ATAN2(SUMS,SUMC)/TWOPI -210 JBASE=JL + JBASE=JL + end do ! !*********************************************************************** !* HERE F AND V+U OF THE SHALLOW WATER CONSTITUENTS ARE COMPUTED FROM @@ -2326,14 +2328,14 @@ subroutine flex_tidana_webpage(IX,IY,XLON,XLAT,KD1,KD2,ndef, itrend, RES, SSQ, R rmsr(IDEF)=0.d0 resmax(IDEF)=0. - do 100 i=1,n + do i=1,n yy=q(i,nmaxp1) rmsr(IDEF)=rmsr(IDEF)+yy*yy IF (abs(yy).gt.resmax(IDEF)) then resmax(IDEF)=abs(yy) imax(IDEF)=i END IF -100 continue + end do 160 format(' ',7i2,f15.5,f10.5,i6) IF (rmsr(IDEF).gt.1.e-10) then rmsr(IDEF)=dsqrt(rmsr(IDEF)/(n-m)) diff --git a/model/src/w3triamd.F90 b/model/src/w3triamd.F90 index bd40d9877..bf5905190 100644 --- a/model/src/w3triamd.F90 +++ b/model/src/w3triamd.F90 @@ -597,7 +597,7 @@ SUBROUTINE GET_BOUNDARY_STATUS(STATUS) EXIT END IF END DO - END SUBROUTINE + END SUBROUTINE GET_BOUNDARY_STATUS !/ -------------------------------------------------------------------/ SUBROUTINE READMSHOBC(NDS, FNAME, TMPSTA, UGOBCOK) @@ -900,7 +900,7 @@ SUBROUTINE SPATIAL_GRID !STOP END IF END DO - END SUBROUTINE + END SUBROUTINE SPATIAL_GRID !/--------------------------------------------------------------------/ ! !/--------------------------------------------------------------------/ @@ -1020,7 +1020,7 @@ SUBROUTINE NVECTRI END DO - END SUBROUTINE + END SUBROUTINE NVECTRI !/--------------------------------------------------------------------------- !/------------------------------------------------------------------------ @@ -1129,7 +1129,7 @@ SUBROUTINE COUNT(TRIGPTEMP) ENDDO COUNTOT=J -END SUBROUTINE + END SUBROUTINE COUNT !/---------------------------------------------------------------------------- SUBROUTINE COORDMAX @@ -1201,7 +1201,7 @@ SUBROUTINE COORDMAX SX = MINVAL(LEN(:,:)) SY = SX ! - END SUBROUTINE + END SUBROUTINE COORDMAX !------------------------------------------------------------------------- SUBROUTINE AREA_SI(IMOD) @@ -1452,7 +1452,7 @@ SUBROUTINE AREA_SI(IMOD) DEALLOCATE(PTABLE) - END SUBROUTINE + END SUBROUTINE AREA_SI SUBROUTINE IS_IN_UNGRID(IMOD, XTIN, YTIN, ITOUT, IS, JS, RW) !/ ------------------------------------------------------------------- @@ -2101,7 +2101,7 @@ SUBROUTINE W3NESTUG(DISTMIN,FLOK) 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOBC : '/ & ' NUMBER OF MAPSTA=2 DIFFERS FROM NUMBER IN nest.ww3 '/ & ' CHECK nest.ww3 AND ww3_grid.inp ',2I8/) -END SUBROUTINE + END SUBROUTINE W3NESTUG !/ ------------------------------------------------------------------- / @@ -2477,7 +2477,7 @@ SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & DEALLOCATE(PREVVERT, STAT=ISTAT) CHECK_DEALLOC_STATUS ( ISTAT ) - END SUBROUTINE + END SUBROUTINE GET_BOUNDARY !/ ------------------------------------------------------------------- / @@ -2558,7 +2558,7 @@ SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) ELSE IPREV=I+1 END IF - END SUBROUTINE + END SUBROUTINE TRIANG_INDEXES !/ ------------------------------------------------------------------- / @@ -2665,7 +2665,7 @@ SUBROUTINE GET_INTERFACE() ENDIF #endif - END SUBROUTINE + END SUBROUTINE GET_INTERFACE !/ ------------------------------------------------------------------- / SUBROUTINE SET_UG_IOBP() !/ diff --git a/model/src/w3updtmd.F90 b/model/src/w3updtmd.F90 index 1ee8b8195..c4335222e 100644 --- a/model/src/w3updtmd.F90 +++ b/model/src/w3updtmd.F90 @@ -2283,7 +2283,7 @@ SUBROUTINE W3ULEV ( A, VA ) I2 = 2 END IF ! - DO 250, IK=IK0, NK + DO IK=IK0, NK ! 230 CONTINUE IF ( WNO(IK) .GT. WN(I2,ISEA) ) THEN @@ -2315,6 +2315,7 @@ SUBROUTINE W3ULEV ( A, VA ) END IF ! 250 CONTINUE + END DO 251 CONTINUE ! ! 2.f Convert discrete action densities to spectrum diff --git a/model/src/w3wavset.F90 b/model/src/w3wavset.F90 index e3e04c6d0..8837acb6a 100644 --- a/model/src/w3wavset.F90 +++ b/model/src/w3wavset.F90 @@ -216,7 +216,7 @@ SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) END DO CALL PDLIB_exchange1Dreal(DVDX) CALL PDLIB_exchange1Dreal(DVDY) - END SUBROUTINE + END SUBROUTINE DIFFERENTIATE_XYDIR_NATIVE !/ ------------------------------------------------------------------- / !> !> @brief Differentiate xy based on mapsta, using linear shape function. @@ -356,7 +356,7 @@ SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) END DO CALL PDLIB_exchange1Dreal(DVDX) CALL PDLIB_exchange1Dreal(DVDY) - END SUBROUTINE + END SUBROUTINE DIFFERENTIATE_XYDIR_MAPSTA !/ ------------------------------------------------------------------- / !> !> @brief Driver routine for xydir. @@ -441,7 +441,7 @@ SUBROUTINE DIFFERENTIATE_XYDIR(VAR, DVDX, DVDY) REAL(8), INTENT(OUT) :: DVDX(npa), DVDY(npa) CALL DIFFERENTIATE_XYDIR_MAPSTA(VAR, DVDX, DVDY) ! CALL DIFFERENTIATE_XYDIR_NATIVE(VAR, DVDX, DVDY) - END SUBROUTINE + END SUBROUTINE DIFFERENTIATE_XYDIR !/ ------------------------------------------------------------------- / !> !> @brief Setup boundary pointer. @@ -594,7 +594,7 @@ SUBROUTINE TRIG_COMPUTE_LH_STRESS(F_X, F_Y, DWNX) WRITE(740+IAPROC,*) 'sum(F_Y)=', sum(F_Y) FLUSH(740+IAPROC) #endif - END SUBROUTINE + END SUBROUTINE TRIG_COMPUTE_LH_STRESS !/ ------------------------------------------------------------------- / !> !> @brief Differentiate other way around. @@ -696,7 +696,7 @@ SUBROUTINE TRIG_COMPUTE_DIFF(IE, I1, UGRAD, VGRAD) h=2.0*PDLIB_TRIA(IE) UGRAD=-(y(IP3) - y(IP2))/h VGRAD= (x(IP3) - x(IP2))/h - END SUBROUTINE + END SUBROUTINE TRIG_COMPUTE_DIFF !/ ------------------------------------------------------------------- / !> !> @brief Setup system matrix for solutions of wave setup eq. @@ -876,7 +876,7 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY, DWNX, ACTIVE, ACTIVE eOff=0 END DO END IF - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_COMPUTE_SYSTEM !/ ------------------------------------------------------------------- / !> !> @brief Preconditioner. @@ -1010,7 +1010,7 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC WRITE(740+IAPROC,*) 'Diag, quot=', maxval(ListDiag)/minval(ListDiag) END IF CALL PDLIB_exchange1Dreal(TheOut) - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_APPLY_PRECOND !/ ------------------------------------------------------------------- / !> !> @brief @@ -1113,7 +1113,7 @@ SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut, ACTIVE, ACTIVESEC) END IF END DO CALL PDLIB_exchange1Dreal(TheOut) - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_APPLY_FCT !/ ------------------------------------------------------------------- / !> !> @brief Scalar product plus exchange. @@ -1224,7 +1224,7 @@ SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) CALL MPI_RECV(lScal,1,rtype, 0, 23, MPI_COMM_WCMP, istatus, ierr) END IF eScal=lScal(1) - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_SCALAR_PROD !/ ------------------------------------------------------------------- / !> !> @brief Poisson equation solver. @@ -1404,7 +1404,7 @@ SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut, ACTIVE, A END DO END DO TheOut=V_X - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR !/ ------------------------------------------------------------------- / !> !> @brief Set mean value. @@ -1528,7 +1528,7 @@ SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO(TheVar) DO IP=1,npa TheVar(IP)=TheVar(IP) - TheMean END DO - END SUBROUTINE + END SUBROUTINE TRIG_SET_MEANVALUE_TO_ZERO !/ ------------------------------------------------------------------- / !> !> @brief Compute active node for setup comp. @@ -1634,7 +1634,7 @@ SUBROUTINE COMPUTE_ACTIVE_NODE(DWNX, ACTIVE) WRITE(740+IAPROC,*) 'nbActive=', nbActive, ' npa=', npa FLUSH(740+IAPROC) #endif - END SUBROUTINE + END SUBROUTINE COMPUTE_ACTIVE_NODE !/ ------------------------------------------------------------------- / !> !> @brief Setup computation. @@ -1792,7 +1792,7 @@ SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION WRITE(740+IAPROC,*) 'Now exiting TRIG_WAVE_SETUP_COMPUTATION' FLUSH(740+IAPROC) #endif - END SUBROUTINE + END SUBROUTINE TRIG_WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / !> !> @brief Wave setup for FD grids. @@ -1959,7 +1959,7 @@ SUBROUTINE PREPARATION_FD_SCHEME(IMOD) PDLIB_I_DIAG(ISEA)=J PDLIB_IA(ISEA+1)=J+1 END DO - END SUBROUTINE + END SUBROUTINE PREPARATION_FD_SCHEME !/ ------------------------------------------------------------------- / !> !> @brief Compute off diagonal for FD grids. @@ -2054,7 +2054,7 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_FCT(ASPAR, TheIn, TheOut) TheOut(IP)=TheOut(IP) + eCoeff*TheIn(JP) END DO END DO - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_APPLY_FCT !/ ------------------------------------------------------------------- / !> !> @brief Preconditioning for FD grids. @@ -2168,7 +2168,7 @@ SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND(ASPAR, TheIn, TheOut) TheOut(IP)=TheIn(IP)/ASPAR(J) END DO END IF - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_APPLY_PRECOND !/ ------------------------------------------------------------------- / !> !> @brief Radiation stresses for FD grids. @@ -2296,7 +2296,7 @@ SUBROUTINE FD_COLLECT_SXX_XY_YY(SXX_t, SXY_t, SYY_t) CALL MPI_SEND(SXY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) CALL MPI_SEND(SYY_p,NSEAL,rtype, 0, 83, MPI_COMM_WCMP, ierr) END IF - END SUBROUTINE + END SUBROUTINE FD_COLLECT_SXX_XY_YY !/ ------------------------------------------------------------------- / !> !> @brief Setup fluxes. @@ -2449,7 +2449,7 @@ SUBROUTINE FD_COMPUTE_LH_STRESS(SXX_t, SXY_t, SYY_t, FX, FY) FX(ISEA)=eFX FY(ISEA)=eFY END DO - END SUBROUTINE + END SUBROUTINE FD_COMPUTE_LH_STRESS !/ ------------------------------------------------------------------- / !> !> @brief Differences on FD grids. @@ -2557,7 +2557,7 @@ SUBROUTINE FD_COMPUTE_DIFF(IEDGE, ISEA, UGRAD, VGRAD, dist) UGRAD=-deltaX/dist VGRAD=-deltaY/dist END IF - END SUBROUTINE + END SUBROUTINE FD_COMPUTE_DIFF !/ ------------------------------------------------------------------- / !> !> @brief Setup matrix on FD grids. @@ -2675,7 +2675,7 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM(ASPAR, B, FX, FY) END DO END DO END DO - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_COMPUTE_SYSTEM !/ ------------------------------------------------------------------- / !> !> @brief Scalar product. @@ -2763,7 +2763,7 @@ SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD(V1, V2, eScal) DO IP=1,NX eScal=eScal + V1(IP)*V2(IP) END DO - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_SCALAR_PROD !/ ------------------------------------------------------------------- / !> !> @brief Poisson solver on FD grids. @@ -2887,7 +2887,7 @@ SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR(ASPAR, B, TheOut) END DO END DO TheOut=V_X - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_SOLVE_POISSON_NEUMANN_DIR !/ ------------------------------------------------------------------- / !> !> @brief Set mean value. @@ -2979,7 +2979,7 @@ SUBROUTINE FD_SET_MEANVALUE_TO_ZERO(TheVar) DO IP=1,NX TheVar(IP)=TheVar(IP) - TheMean END DO - END SUBROUTINE + END SUBROUTINE FD_SET_MEANVALUE_TO_ZERO !/ ------------------------------------------------------------------- / !> !> @brief Wave setup comp on FD grids. @@ -3088,7 +3088,7 @@ SUBROUTINE FD_WAVE_SETUP_COMPUTATION DO ISEA=1,NSEA ZETA_SETUP(ISEA)=ZETA_WORK(ISEA) END DO - END SUBROUTINE + END SUBROUTINE FD_WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / !> !> @brief General driver. @@ -3191,7 +3191,7 @@ SUBROUTINE WAVE_SETUP_COMPUTATION WRITE(740+IAPROC,*) 'Begin WAVE_SETUP_COMPUTATION' FLUSH(740+IAPROC) #endif - END SUBROUTINE + END SUBROUTINE WAVE_SETUP_COMPUTATION !/ ------------------------------------------------------------------- / - END MODULE +END MODULE W3WAVSET !/ ------------------------------------------------------------------- / diff --git a/model/src/wminitmd.F90 b/model/src/wminitmd.F90 index a27221f4d..0028a2811 100644 --- a/model/src/wminitmd.F90 +++ b/model/src/wminitmd.F90 @@ -2852,7 +2852,12 @@ SUBROUTINE WMINIT ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ELSE NDS(9) = -1 END IF +#ifdef W3_MPI END IF +#endif +#ifdef W3_SHRD + END IF +#endif ! END DO ! @@ -5680,7 +5685,8 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDST,9082) GRSTAT(I), TOUTP(:,I), TSYNC(:,I) #endif ! - END DO + END DO ! DO I=1, NRGRD + ! #ifdef W3_MPI CALL MPI_BARRIER (MPI_COMM_MWAVE,IERR_MPI) @@ -5969,7 +5975,12 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & ELSE NDS(9) = -1 END IF - END IF +#ifdef W3_MPI + END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL) +#endif +#ifdef W3_SHRD + END IF ! IF ( .NOT. FLRBPI(I) .AND. FLBPI ) +#endif ! END DO ! @@ -6081,7 +6092,7 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & END DO #endif ! - END IF + END IF ! IF ( UNIPTS ) ! ! 8.c.6 Output ! @@ -6119,7 +6130,7 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSS,937) 'No lower rank grid dependencies' IF ( NMPLOG .EQ. IMPROC ) & WRITE (MDSO,937) 'No lower rank grid dependencies' - END IF + END IF ! IF ( MAXVAL(GRDLOW(:,0)) .GT. 0 ) DEALLOCATE ( FLRBPI ) ! IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) THEN @@ -6150,7 +6161,7 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSS,937) 'No same rank grid dependencies' IF ( NMPLOG .EQ. IMPROC ) & WRITE (MDSO,937) 'No same rank grid dependencies' - END IF + END IF ! IF ( MAXVAL(GRDEQL(:,0)) .GT. 0 ) ! IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) THEN IF ( MDSS.NE.MDSO .AND. NMPSCR.EQ.IMPROC ) & @@ -6180,7 +6191,7 @@ SUBROUTINE WMINITNML ( IDSI, IDSO, IDSS, IDST, IDSE, IFNAME, & WRITE (MDSS,937) 'No higher rank grid dependencies' IF ( NMPLOG .EQ. IMPROC ) & WRITE (MDSO,937) 'No higher rank grid dependencies' - END IF + END IF ! IF ( MAXVAL(GRDHGH(:,0)) .GT. 0 ) ! #ifdef W3_T WRITE (MDST,9083) diff --git a/model/src/wmscrpmd.F90 b/model/src/wmscrpmd.F90 index a5f4cdde3..e66ebade2 100644 --- a/model/src/wmscrpmd.F90 +++ b/model/src/wmscrpmd.F90 @@ -1426,7 +1426,7 @@ SUBROUTINE TRIANG_INDEXES(I, INEXT, IPREV) ELSE IPREV=I+1 END IF - END SUBROUTINE + END SUBROUTINE TRIANG_INDEXES !/ ------------------------------------------------------------------- / !> @@ -1692,7 +1692,7 @@ SUBROUTINE GET_BOUNDARY(MNP, MNE, TRIGP, IOBP, NEIGHBOR_PREV, & DEALLOCATE(PREVVERT, STAT=ISTAT) CHECK_DEALLOC_STATUS ( ISTAT ) - END SUBROUTINE + END SUBROUTINE GET_BOUNDARY !/ ------------------------------------------------------------------- / !> !> @brief Adjust element longitude coordinates for elements straddling the diff --git a/model/src/wmwavemd.F90 b/model/src/wmwavemd.F90 index 8dbf71f30..d942e86b8 100644 --- a/model/src/wmwavemd.F90 +++ b/model/src/wmwavemd.F90 @@ -495,7 +495,12 @@ SUBROUTINE WMWAVE ( TEND ) DONE = .TRUE. END IF ! - END IF +#ifdef W3_MPI + END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) +#endif +#ifdef W3_SHRD + END IF ! IF ( GRSTAT(I) .EQ. 0 ) +#endif ! ! 2.b Update input and TDATA ! @@ -537,7 +542,7 @@ SUBROUTINE WMWAVE ( TEND ) #ifdef W3_MPI GRSTAT(I) = 1 DONE = .TRUE. - END IF + END IF ! IF ( .NOT. GRSYNC(J) ) #endif ! #ifdef W3_MPRF @@ -546,7 +551,12 @@ SUBROUTINE WMWAVE ( TEND ) 'ST00', I #endif ! - END IF +#ifdef W3_MPI + END IF ! IF ( GRSTAT(I).EQ.0 .AND. .NOT.FLSYNC(I) .AND. MPI_COMM_GRD .NE. MPI_COMM_NULL ) +#endif +#ifdef W3_SHRD + END IF ! IF ( GRSTAT(I) .EQ. 0 ) +#endif ! ! 2.d Synchronize in parts ( !/MPI ) ! @@ -590,11 +600,11 @@ SUBROUTINE WMWAVE ( TEND ) #ifdef W3_MPI FLSYNC(I) = .TRUE. CYCLE LOOP_JJ - END IF + END IF ! IF ( FLSYNC(I) ) #endif ! #ifdef W3_MPI - END IF + END IF ! IF ( GRSTAT(I).EQ.0 .AND. GRSYNC(J) #endif ! ! 3. Update data from lower ranked grids ---------------------------- / @@ -615,7 +625,7 @@ SUBROUTINE WMWAVE ( TEND ) #endif DONE = .TRUE. END IF - END IF + END IF ! IF ( GRSTAT(I) .EQ. 1 .AND. TSYNC(1,I) .NE. -1 ) ! ! 3.b Normal processing ! @@ -665,14 +675,14 @@ SUBROUTINE WMWAVE ( TEND ) #endif GRSTAT(I) = 2 DONE = .TRUE. - END IF + END IF ! IF ( FLAGOK ) ! #ifdef W3_MPRF CALL PRTIME ( PRFTN ) WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & 'ST01', I #endif - END IF + END IF ! IF ( GRSTAT(I) .EQ. 1 ) ! ! 4. Update model time step ----------------------------------------- / ! ( GRSTAT = 2 ) @@ -725,7 +735,7 @@ SUBROUTINE WMWAVE ( TEND ) ELSE WRITE (MDST,9041) TMAX(:,I) #endif - END IF + END IF ! IF ( DTTST .LE. 0 ) ! ! 4.b Lowest ranked grids, minimum of all TMAXes ! @@ -753,7 +763,12 @@ SUBROUTINE WMWAVE ( TEND ) FLAGOK = .FALSE. EXIT END IF - END IF +#ifdef W3_MPI + END IF ! IF ( TIME(1).NE.-1 .AND. MPI_COMM_GRD.NE.MPI_COMM_NULL ) +#endif +#ifdef W3_SHRD + END IF ! IF ( TIME(1) .NE. -1 ) THEN +#endif END DO ! ! 4.b.2 Check availability of data @@ -817,7 +832,7 @@ SUBROUTINE WMWAVE ( TEND ) #endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 ! - END IF + END IF ! IF ( FLAGOK ) ! ! 4.c Other grids, logical from relations and TMAXes ! @@ -896,11 +911,11 @@ SUBROUTINE WMWAVE ( TEND ) #endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 ! - END IF + END IF ! IF ( FLAGOK ) ! - END IF + END IF ! 4.b IF ( GRANK(I) .EQ. 1 ) ! - END IF + END IF ! 4. IF ( GRSTAT(I) .EQ. 2 ) ! ! 5. Run the wave model --------------------------------------------- / ! ( GRSTAT = 3 ) w3xdatmd data structures set in W3WAVE @@ -953,7 +968,12 @@ SUBROUTINE WMWAVE ( TEND ) 'ST03', I #endif ! - END IF +#ifdef W3_MPI + END IF ! IF ( GRSTAT(I).EQ.3 .AND. MPI_COMM_GRD .EQ. MPI_COMM_NULL ) +#endif +#ifdef W3_SHRD + END IF ! IF ( GRSTAT(I) .EQ. 3 ) +#endif ! ! 6. Reconcile grids with same rank --------------------------------- / ! and stage data transfer to higher and lower ranked grids. @@ -1013,9 +1033,9 @@ SUBROUTINE WMWAVE ( TEND ) IF ( INGRP(J,0) .GT. 1 ) WRITE (MDST,9006) #endif IF ( INGRP(J,0) .GT. 1 ) GOTO 1111 - END IF + END IF ! IF ( FLAGOK ) ! - END IF + END IF ! IF ( .NOT. FLEQOK(I) ) ! ! 6.b Call gathering routine, reset FLEQOK and cycle ! @@ -1067,7 +1087,7 @@ SUBROUTINE WMWAVE ( TEND ) #endif CYCLE LOOP_JJ ! - END IF + END IF ! IF ( GRSTAT(I) .EQ. 5 ) ! #ifdef W3_MPRF CALL PRTIME ( PRFTN ) @@ -1075,7 +1095,7 @@ SUBROUTINE WMWAVE ( TEND ) get_memory(), 'ST04', I #endif ! - END IF + END IF ! 6. IF ( GRSTAT(I) .EQ. 4 ) ! ! 7. Reconcile with higher ranked grids ----------------------------- / ! ( GRSTAT = 5 ) @@ -1137,9 +1157,9 @@ SUBROUTINE WMWAVE ( TEND ) #endif GRSTAT(I) = 6 DONE = .TRUE. - END IF + END IF ! IF ( FLAGOK ) ! - END IF + END IF ! IF ( GRDHGH(I,0) .EQ. 0 ) ! ! 7.c Stage data @@ -1164,7 +1184,7 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDSP,991) PRFT0, PRFTN, get_memory(), & 'ST05', I #endif - END IF + END IF ! 7. IF ( GRSTAT(I) .EQ. 5 ) ! ! 8. Perform data assimmilation ------------------------------------- / ! ( GRSTAT = 6 ) Placeholder only ..... @@ -1183,7 +1203,7 @@ SUBROUTINE WMWAVE ( TEND ) 'ST06', I #endif DONE = .TRUE. - END IF + END IF ! IF ( GRSTAT(I) .EQ. 6 ) ! ! 9. Perform output ------------------------------------------------- / ! ( GRSTAT = 7 ) w3xdatmd data structures set in W3WAVE @@ -1229,7 +1249,12 @@ SUBROUTINE WMWAVE ( TEND ) DONE = .TRUE. END IF ! - END IF +#ifdef W3_MPI + END IF ! IF ( GRSTAT(I).EQ.7 .AND. .NOT.FLSYNC(I) ) +#endif +#ifdef W3_SHRD + END IF ! IF ( GRSTAT(I) .EQ. 7 ) +#endif ! ! 9.b Perform output ! @@ -1312,7 +1337,7 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDST,9091) TOUTP(:,I) #endif ! - END IF + END IF ! IF ( FLG_O1 ) ! ! 9.d Process unified point output for selected grid @@ -1345,9 +1370,9 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDST,9092) NOPTS #endif ! - END IF + END IF ! IF ( FLG_O2 ) ! - END IF + END IF ! IF ( UNIPTS ) ! #ifdef W3_MPRF CALL PRTIME ( PRFTN ) @@ -1391,7 +1416,7 @@ SUBROUTINE WMWAVE ( TEND ) EXIT END IF END DO - END IF + END IF ! IF ( FLOUT(JO) ) #endif ! #ifdef W3_MPI @@ -1405,7 +1430,7 @@ SUBROUTINE WMWAVE ( TEND ) #endif ! #ifdef W3_MPI - END DO + END DO ! DO JO=1, NOTYPE #endif ! ! Checkpoint @@ -1429,7 +1454,7 @@ SUBROUTINE WMWAVE ( TEND ) EXIT END IF END DO - END IF + END IF ! IF ( FLOUT(JO) ) #endif ! #ifdef W3_MPI @@ -1448,7 +1473,7 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDST,9991) TOUTP(:,I) #endif #ifdef W3_MPI - END IF + END IF ! 9.b IF ( MPI_COMM_GRD .NE. MPI_COMM_NULL ) #endif ! ! 9.f Finish up @@ -1456,7 +1481,7 @@ SUBROUTINE WMWAVE ( TEND ) GRSTAT(I) = 8 DONE = .TRUE. ! - END IF + END IF ! 9.b IF ( GRSTAT(I) .EQ. 7 ) ! ! 10. Go to next time step ------------------------------------------- / ! ( GRSTAT = 8 ) ( 9 added for diagnostic output only ... ) @@ -1531,11 +1556,11 @@ SUBROUTINE WMWAVE ( TEND ) WRITE (MDSP,991) PRFT0, PRFTN, & get_memory(), 'UPTS',I #endif - END IF + END IF ! IF ( FLAGOK ) ! ELSE FLAGOK = .TRUE. - END IF + END IF ! IF ( FLAGOK ) ! ! 10.b Regular processing ! @@ -1552,14 +1577,14 @@ SUBROUTINE WMWAVE ( TEND ) #ifdef W3_T WRITE (MDST,9003) I, GRSTAT(I) #endif - END IF + END IF ! IF ( FLAGOK ) ! IF ( GRSTAT(I).EQ.9 .OR. GRSTAT(I).EQ.99 ) THEN TSYNC(1,I) = -1 TSYNC(2,I) = 0 END IF ! - END IF + END IF ! 10. IF ( GRSTAT(I) .EQ. 8 ) ! ! ... End of loops started in 1. ------------------------------------- / ! diff --git a/model/src/ww3_prtide.F90 b/model/src/ww3_prtide.F90 index 611c43866..21b772e9a 100644 --- a/model/src/ww3_prtide.F90 +++ b/model/src/ww3_prtide.F90 @@ -657,13 +657,14 @@ PROGRAM W3PRTIDE FX1DL(IND) = WCURTIDEX FY1DL(IND) = WCURTIDEY FA1DL(IND) = 0. + END DO ! NX #endif #ifdef W3_SHRD FX(IX,IY) = WCURTIDEX FY(IX,IY) = WCURTIDEY FA(IX,IY) = 0. -#endif END DO ! NX +#endif ! ! Gather from other MPI tasks @@ -749,14 +750,16 @@ PROGRAM W3PRTIDE FX1DL(IND) = 0. FY1DL(IND) = 0. FA1DL(IND) = WCURTIDEX + END DO ! NX #endif #ifdef W3_SHRD FX(IX,IY) = 0. FY(IX,IY) = 0. FA(IX,IY) = WCURTIDEX + END DO ! NX #endif - END DO ! NX + ! ! Gather from other MPI tasks