grid_coords.F

Go to the documentation of this file.

#include "cppdefs.h"
#if defined FLOATS || defined STATIONS
       SUBROUTINE grid_coords (ng, model)
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This routine converts initial locations to fractional grid (I,J)    !
!  coordinates, if appropriate.                                        !
!                                                                      !
!=======================================================================
!
      USE mod_param
      USE mod_parallel
# ifdef FLOATS
      USE mod_floats
# endif
      USE mod_grid
      USE mod_scalars
      USE roms_interpolate_mod
!
# ifdef DISTRIBUTE
      USE distribute_mod, ONLY : mp_collect
# endif
!
      implicit none
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
!
!  Local variable declarations.
!
      integer :: IstrR, Iend, JstrR, Jend
      integer :: LBi, UBi, LBj, UBj
      integer :: i, j, k, l, mc
 
      real(r8), parameter :: spv = 0.0_r8
 
# ifdef FLOATS
      real(r8) :: Xstr, Xend, Ystr, Yend, zfloat
      logical, dimension(Nfloats(ng)) :: my_thread
      real(r8), dimension(Nfloats(ng)) :: Iflt, Jflt
#  ifdef SOLVE3D
      real(r8), dimension(Nfloats(ng)) :: Kflt
#  endif
# endif
 
# ifdef STATIONS
      real(r8), dimension(Nstation(ng)) :: Slon, Slat
      real(r8), dimension(Nstation(ng)) :: Ista, Jsta
# endif
!
!-----------------------------------------------------------------------
!  Determine searching model grid box and arrays bounds.
!-----------------------------------------------------------------------
!
# ifdef DISTRIBUTE
      istrr=bounds(ng)%IstrR(myrank)
      iend =bounds(ng)%Iend (myrank)
      jstrr=bounds(ng)%JstrR(myrank)
      jend =bounds(ng)%Jend (myrank)
# else
      istrr=0
      iend =lm(ng)
      jstrr=0
      jend =mm(ng)
# endif
!
      lbi=lbound(grid(ng)%h,dim=1)
      ubi=ubound(grid(ng)%h,dim=1)
      lbj=lbound(grid(ng)%h,dim=2)
      ubj=ubound(grid(ng)%h,dim=2)
 
# ifdef FLOATS
!
      xstr=real(bounds(ng)%Istr(myrank),r8)-0.5_r8
      xend=real(bounds(ng)%Iend(myrank),r8)+0.5_r8
      ystr=real(bounds(ng)%Jstr(myrank),r8)-0.5_r8
      yend=real(bounds(ng)%Jend(myrank),r8)+0.5_r8
!
!-----------------------------------------------------------------------
!  If applicable, convert initial floats locations (Flon,Flat) to
!  fractional grid coordinates.
!-----------------------------------------------------------------------
!
      IF (spherical) THEN
        IF (lfloats(ng)) THEN
          mc=drifter(ng)%Findex(0)
          IF (drifter(ng)%Findex(0).gt.0) THEN
            CALL hindices (ng, lbi, ubi, lbj, ubj,                      &
     &                     istrr, iend+1, jstrr, jend+1,                &
     &                     grid(ng)%angler,                             &
     &                     grid(ng)%lonr,                               &
     &                     grid(ng)%latr,                               &
     &                     1, mc, 1, 1,                                 &
     &                     1, mc, 1, 1,                                 &
     &                     drifter(ng)%Flon,                            &
     &                     drifter(ng)%Flat,                            &
     &                     iflt, jflt, spv, .false.)
#  ifdef DISTRIBUTE
            CALL mp_collect (ng, model, mc, spv, iflt)
            CALL mp_collect (ng, model, mc, spv, jflt)
#  endif
            DO i=1,mc
              l=drifter(ng)%Findex(i)
              drifter(ng)%Tinfo(ixgrd,l)=iflt(i)
              drifter(ng)%Tinfo(iygrd,l)=jflt(i)
            END DO
          END IF
        END IF
      END IF
 
#  ifdef SOLVE3D
!
!  Determine which node bounds the initial float location.
!
#   ifdef DISTRIBUTE
      IF (lfloats(ng)) THEN
        DO l=1,nfloats(ng)
          IF ((xstr.le.drifter(ng)%Tinfo(ixgrd,l)).and.                 &
     &        (drifter(ng)%Tinfo(ixgrd,l).lt.xend).and.                 &
     &        (ystr.le.drifter(ng)%Tinfo(iygrd,l)).and.                 &
     &        (drifter(ng)%Tinfo(iygrd,l).lt.yend)) THEN
            my_thread(l)=.true.
          ELSE
            my_thread(l)=.false.
          END IF
        END DO
      END IF
#   else
      DO l=1,nfloats(ng)
        my_thread(l)=.true.
      END DO
#   endif
#  endif
!
!-----------------------------------------------------------------------
!  Set float initial vertical level position, if inside application
!  grid.  If the initial float depth (in meters) is not found, release
!  float at the surface model level.
!-----------------------------------------------------------------------
!
      DO l=1,nfloats(ng)
        IF (lfloats(ng)) THEN
#  ifdef SOLVE3D
          drifter(ng)%Fz0(l)=spv
          IF (my_thread(l).and.                                         &
     &        ((drifter(ng)%Tinfo(ixgrd,l).ge.0.5_r8).and.              &
     &         (drifter(ng)%Tinfo(iygrd,l).ge.0.5_r8).and.              &
     &         (drifter(ng)%Tinfo(ixgrd,l).le.                          &
     &          real(lm(ng),r8)+0.5_r8).and.                            &
     &         (drifter(ng)%Tinfo(iygrd,l).le.                          &
     &          real(mm(ng),r8)+0.5_r8))) THEN
            zfloat=drifter(ng)%Tinfo(izgrd,l)
            drifter(ng)%Fz0(l)=zfloat           ! Save original value
            kflt(l)=zfloat
            IF (zfloat.le.0.0_r8) THEN
              i=int(drifter(ng)%Tinfo(ixgrd,l)) ! Fractional positions
              j=int(drifter(ng)%Tinfo(iygrd,l)) ! are still in this cell
              IF (zfloat.lt.grid(ng)%z_w(i,j,0)) THEN
                zfloat=grid(ng)%z_w(i,j,0)+5.0_r8
                drifter(ng)%Fz0(l)=zfloat
              END IF
              drifter(ng)%Tinfo(izgrd,l)=real(n(ng),r8)
              DO k=n(ng),1,-1
                IF ((grid(ng)%z_w(i,j,k)-zfloat)*                       &
     &              (zfloat-grid(ng)%z_w(i,j,k-1)).ge.0.0_r8) THEN
                  kflt(l)=real(k-1,r8)+                                 &
     &                    (zfloat-grid(ng)%z_w(i,j,k-1))/               &
     &                    grid(ng)%Hz(i,j,k)
                END IF
              END DO
            END IF
          ELSE
            kflt(l)=spv
          END IF
#  else
          drifter(ng)%Tinfo(izgrd,l)=0.0_r8
#  endif
        END IF
      END DO
#  ifdef SOLVE3D
      IF (lfloats(ng)) THEN
#   ifdef DISTRIBUTE
        CALL mp_collect (ng, model, nfloats(ng), spv, drifter(ng)%Fz0)
        CALL mp_collect (ng, model, nfloats(ng), spv, kflt)
#   endif
        DO l=1,nfloats(ng)
          drifter(ng)%Tinfo(izgrd,l)=kflt(l)
        END DO
      END IF
#  endif
# endif
# ifdef STATIONS
!
!-----------------------------------------------------------------------
!  If applicable, convert station locations (SposX,SposY) to fractional
!  grid coordinates.
!-----------------------------------------------------------------------
!
      IF (spherical) THEN
        mc=0
        DO l=1,nstation(ng)
          IF (scalars(ng)%Sflag(l).gt.0) THEN
            mc=mc+1
            slon(mc)=scalars(ng)%SposX(l)
            slat(mc)=scalars(ng)%SposY(l)
          END IF
        END DO
        IF (mc.gt.0) THEN
          CALL hindices (ng, lbi, ubi, lbj, ubj,                        &
     &                   istrr, iend+1, jstrr, jend+1,                  &
     &                   grid(ng)%angler,                               &
     &                   grid(ng)%lonr,                                 &
     &                   grid(ng)%latr,                                 &
     &                   1, mc, 1, 1,                                   &
     &                   1, mc, 1, 1,                                   &
     &                   slon, slat,                                    &
     &                   ista, jsta,                                    &
     &                   spv, .false.)
#  ifdef DISTRIBUTE
          CALL mp_collect (ng, model, mc, spv, ista)
          CALL mp_collect (ng, model, mc, spv, jsta)
#  endif
          mc=0
          DO l=1,nstation(ng)
            IF (scalars(ng)%Sflag(l).gt.0) THEN
              mc=mc+1
              scalars(ng)%SposX(l)=ista(mc)
              scalars(ng)%SposY(l)=jsta(mc)
            END IF
          END DO
        END IF
      END IF
# endif
      RETURN
      END SUBROUTINE grid_coords
#else
      SUBROUTINE grid_coords
      RETURN
      END SUBROUTINE grid_coords
#endif