polfix_mod.F90

Go to the documentation of this file.

 
 
module polfix_mod
  implicit none
 
  private
  public :: polfixs, polfixv
 
contains
 
  SUBROUTINE polfixs(NM,NX,KM,RLAT,IB,LO,GO)
    IMPLICIT NONE
    !
    INTEGER,    INTENT(IN   ) :: nm, nx, km
    INTEGER,    INTENT(IN   ) :: ib(km)
    !
    LOGICAL*1,  INTENT(INOUT) :: lo(nx,km)
    !
    REAL,       INTENT(IN   ) :: rlat(nm)
    REAL,       INTENT(INOUT) :: go(nx,km)
    !
    REAL,       PARAMETER     :: rlatnp=89.9995
    REAL,       PARAMETER     :: rlatsp=-rlatnp
    !
    INTEGER                   :: k, n
    !
    REAL                      :: wnp, gnp, tnp, wsp, gsp, tsp
    ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    DO k=1,km
       wnp=0.
       gnp=0.
       tnp=0.
       wsp=0.
       gsp=0.
       tsp=0.
       !  AVERAGE MULTIPLE POLE VALUES
       !$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:WNP,GNP,TNP,WSP,GSP,TSP) SCHEDULE(STATIC)
       DO n=1,nm
          IF(rlat(n).GE.rlatnp) THEN
             wnp=wnp+1
             IF(ib(k).EQ.0.OR.lo(n,k)) THEN
                gnp=gnp+go(n,k)
                tnp=tnp+1
             ENDIF
          ELSEIF(rlat(n).LE.rlatsp) THEN
             wsp=wsp+1
             IF(ib(k).EQ.0.OR.lo(n,k)) THEN
                gsp=gsp+go(n,k)
                tsp=tsp+1
             ENDIF
          ENDIF
       ENDDO
       !$OMP END PARALLEL DO
       !  DISTRIBUTE AVERAGE VALUES BACK TO MULTIPLE POLES
       IF(wnp.GT.1) THEN
          IF(tnp.GE.wnp/2) THEN
             gnp=gnp/tnp
          ELSE
             gnp=0.
          ENDIF
          !$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
          DO n=1,nm
             IF(rlat(n).GE.rlatnp) THEN
                IF(ib(k).NE.0) lo(n,k)=tnp.GE.wnp/2
                go(n,k)=gnp
             ENDIF
          ENDDO
          !$OMP END PARALLEL DO
       ENDIF
       IF(wsp.GT.1) THEN
          IF(tsp.GE.wsp/2) THEN
             gsp=gsp/tsp
          ELSE
             gsp=0.
          ENDIF
          !$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
          DO n=1,nm
             IF(rlat(n).LE.rlatsp) THEN
                IF(ib(k).NE.0) lo(n,k)=tsp.GE.wsp/2
                go(n,k)=gsp
             ENDIF
          ENDDO
          !$OMP END PARALLEL DO
       ENDIF
    ENDDO
    ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  END SUBROUTINE polfixs
 
  SUBROUTINE polfixv(NM,NX,KM,RLAT,RLON,IB,LO,UO,VO)
    IMPLICIT NONE
    !
    INTEGER,      INTENT(IN   ) :: ib(km), nm, nx, km
    !
    LOGICAL*1,    INTENT(INOUT) :: lo(nx,km)
    !
    REAL,         INTENT(IN   ) :: rlat(nm), rlon(nm)
    REAL,         INTENT(INOUT) :: uo(nx,km), vo(nx,km)
    !
    REAL,         PARAMETER     :: rlatnp=89.9995
    REAL,         PARAMETER     :: rlatsp=-rlatnp
    REAL,         PARAMETER     :: pi=3.14159265358979
    REAL,         PARAMETER     :: dpr=180./pi
    !
    INTEGER                     :: k, n
    !
    REAL                        :: clon(nm),slon(nm)
    REAL                        :: tnp, unp, vnp, wnp
    REAL                        :: tsp, usp, vsp, wsp
    ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
    DO n=1,nm
       clon(n)=cos(rlon(n)/dpr)
       slon(n)=sin(rlon(n)/dpr)
    ENDDO
    !$OMP END PARALLEL DO
    ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    DO k=1,km
       wnp=0.
       unp=0.
       vnp=0.
       tnp=0.
       wsp=0.
       usp=0.
       vsp=0.
       tsp=0.
       !  AVERAGE MULTIPLE POLE VALUES
       !$OMP PARALLEL DO PRIVATE(N) REDUCTION(+:WNP,UNP,VNP,TNP,WSP,USP,VSP,TSP) SCHEDULE(STATIC)
       DO n=1,nm
          IF(rlat(n).GE.rlatnp) THEN
             wnp=wnp+1
             IF(ib(k).EQ.0.OR.lo(n,k)) THEN
                unp=unp+(clon(n)*uo(n,k)-slon(n)*vo(n,k))
                vnp=vnp+(slon(n)*uo(n,k)+clon(n)*vo(n,k))
                tnp=tnp+1
             ENDIF
          ELSEIF(rlat(n).LE.rlatsp) THEN
             wsp=wsp+1
             IF(ib(k).EQ.0.OR.lo(n,k)) THEN
                usp=usp+(clon(n)*uo(n,k)+slon(n)*vo(n,k))
                vsp=vsp+(-slon(n)*uo(n,k)+clon(n)*vo(n,k))
                tsp=tsp+1
             ENDIF
          ENDIF
       ENDDO
       !$OMP END PARALLEL DO
       !  DISTRIBUTE AVERAGE VALUES BACK TO MULTIPLE POLES
       IF(wnp.GT.1) THEN
          IF(tnp.GE.wnp/2) THEN
             unp=unp/tnp
             vnp=vnp/tnp
          ELSE
             unp=0.
             vnp=0.
          ENDIF
          !$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
          DO n=1,nm
             IF(rlat(n).GE.rlatnp) THEN
                IF(ib(k).NE.0) lo(n,k)=tnp.GE.wnp/2
                uo(n,k)=clon(n)*unp+slon(n)*vnp
                vo(n,k)=-slon(n)*unp+clon(n)*vnp
             ENDIF
          ENDDO
          !$OMP END PARALLEL DO
       ENDIF
       IF(wsp.GT.1) THEN
          IF(tsp.GE.wsp/2) THEN
             usp=usp/wsp
             vsp=vsp/wsp
          ELSE
             usp=0.
             vsp=0.
          ENDIF
          !$OMP PARALLEL DO PRIVATE(N) SCHEDULE(STATIC)
          DO n=1,nm
             IF(rlat(n).LE.rlatsp) THEN
                IF(ib(k).NE.0) lo(n,k)=tsp.GE.wsp/2
                uo(n,k)=clon(n)*usp-slon(n)*vsp
                vo(n,k)=slon(n)*usp+clon(n)*vsp
             ENDIF
          ENDDO
          !$OMP END PARALLEL DO
       ENDIF
    ENDDO
    ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  END SUBROUTINE polfixv
end module polfix_mod