fadup_mod.F90

Go to the documentation of this file.

MODULE fadup_mod

!**** *FADUP_MOD*  - Duplicate FA library

!     Author. 
!     ------- 
!      Philippe Marguinaud *METEO FRANCE*
!      Original : 11-09-2012


USE fa_mod, ONLY : fa_com, new_fa
USE yomhook, ONLY : lhook, dr_hook
USE parkind1, ONLY : jprb, jpim

IMPLICIT NONE

TYPE fadup_params

! librarie FA
  INTEGER (KIND=JPIM) :: ipxtro
  INTEGER (KIND=JPIM) :: ipxlat
  INTEGER (KIND=JPIM) :: ipxniv
  INTEGER (KIND=JPIM) :: ipnxfa
  INTEGER (KIND=JPIM) :: ipnxca
  
  INTEGER (KIND=JPIM) :: ingrib 
  INTEGER (KIND=JPIM) :: inbpdg 
  INTEGER (KIND=JPIM) :: inbcsp 
  INTEGER (KIND=JPIM) :: istron 
  INTEGER (KIND=JPIM) :: ipuila 
  INTEGER (KIND=JPIM) :: idmopl

! fichier
  LOGICAL               :: lnomm 
  LOGICAL               :: louvr
  CHARACTER*256         :: cnomf 
  CHARACTER*32          :: csttu
  LOGICAL               :: lerfa 
  LOGICAL               :: limst 
  INTEGER (KIND=JPIM)   :: inimes 
  CHARACTER*32          :: cnomc
  INTEGER (KIND=JPIM)   :: ifact

! cadre
  INTEGER (KIND=JPIM) :: ityptr 
  INTEGER (KIND=JPIM) :: itronc 
  INTEGER (KIND=JPIM) :: inlati 
  INTEGER (KIND=JPIM) :: inxlon 
  INTEGER (KIND=JPIM) :: iniver
  
  INTEGER (KIND=JPIM), POINTER :: inlopa (:) => null ()
  INTEGER (KIND=JPIM), POINTER :: inozpa (:) => null ()
  
  REAL (KIND=JPRB) :: zslapo
  REAL (KIND=JPRB) :: zclopo 
  REAL (KIND=JPRB) :: zslopo
  REAL (KIND=JPRB) :: zcodil
  REAL (KIND=JPRB) :: zrefer
  
  REAL (KIND=JPRB), POINTER :: zsinla (:) => null ()
  REAL (KIND=JPRB), POINTER :: zahybr (:) => null ()
  REAL (KIND=JPRB), POINTER :: zbhybr (:) => null ()

  REAL (KIND=JPRB), POINTER :: xlap1d  (:,:)   => null ()
  REAL (KIND=JPRB), POINTER :: xlap1da (:,:)   => null ()
  REAL (KIND=JPRB), POINTER :: xlap2d  (:,:,:) => null ()
  REAL (KIND=JPRB), POINTER :: xlap2da (:,:,:) => null ()
  
  LOGICAL :: lgard

! date
  INTEGER (KIND=JPIM), POINTER :: idatef (:) => null ()

! 
  INTEGER (KIND=JPIM) :: iulout_fa, iulout_lfi

  INTEGER (KIND=JPIM) :: iextern = 0_jpim
  CHARACTER (LEN=64)  :: cmodel  = ''
  INTEGER (KIND=JPIM) :: nidcen  = 0_jpim

END TYPE fadup_params

PRIVATE :: fadup1, fadup2

CONTAINS

SUBROUTINE fadup1 (YDFA, YDDFP, KUNIT, KERR)

! Record necessary FA parameters 

TYPE(fa_com)                        :: YDFA
TYPE(fadup_params)                  :: YDDFP
INTEGER (KIND=JPIM),   INTENT (IN)  :: KUNIT
INTEGER (KIND=JPIM),   INTENT (OUT) :: KERR

INTEGER (KIND=JPIM) :: IVAL

CHARACTER (LEN=64) :: CLMODEL

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUP1',0,zhook_handle)

yddfp%IPXTRO = int(ydfa%JPXTRO)
yddfp%IPXLAT = int(ydfa%JPXLAT)
yddfp%IPXNIV = int(ydfa%JPXNIV)
yddfp%IPNXFA = int(ydfa%JPNXFA)
yddfp%IPNXCA = int(ydfa%JPNXCA)

CALL favori_mt (ydfa,                                     &
&               yddfp%INGRIB, yddfp%INBPDG, yddfp%INBCSP, &
&               yddfp%ISTRON, yddfp%IPUILA, yddfp%IDMOPL)

CALL faiopt_mt (ydfa, kerr, kunit, yddfp%LNOMM, yddfp%CNOMF,         &
&               yddfp%CSTTU, yddfp%LERFA, yddfp%LIMST, yddfp%INIMES, &
&               yddfp%CNOMC)

CALL lfiofm_mt (ydfa%LFI, kerr, kunit, yddfp%IFACT, yddfp%LOUVR)

ALLOCATE (yddfp%INLOPA (ydfa%JPXPAH), yddfp%INOZPA (ydfa%JPXIND),   &
&         yddfp%ZSINLA (ydfa%JPXGEO), yddfp%ZAHYBR (0:ydfa%JPXNIV), &
&         yddfp%ZBHYBR (0:ydfa%JPXNIV), yddfp%IDATEF (ydfa%JPLDAT*2))

CALL facies_mt (ydfa,                                                   &
&               yddfp%CNOMC,  yddfp%ITYPTR, yddfp%ZSLAPO, yddfp%ZCLOPO, &
&               yddfp%ZSLOPO, yddfp%ZCODIL, yddfp%ITRONC, yddfp%INLATI, &
&               yddfp%INXLON, yddfp%INLOPA, yddfp%INOZPA, yddfp%ZSINLA, &
&               yddfp%INIVER, yddfp%ZREFER, yddfp%ZAHYBR, yddfp%ZBHYBR, &
&               yddfp%LGARD)

CALL fadiex_mt (ydfa, kerr, kunit, yddfp%IDATEF)

yddfp%IULOUT_FA  = ydfa%NULOUT
yddfp%IULOUT_LFI = ydfa%LFI%NULOUT

IF (.NOT. ydfa%LIXLAP) THEN
  yddfp%XLAP1D  => ydfa%XLAP1D
  yddfp%XLAP1DA => ydfa%XLAP1DA
  yddfp%XLAP2D  => ydfa%XLAP2D
  yddfp%XLAP2DA => ydfa%XLAP2DA
ENDIF

CALL faregu (kunit, 'EXTERN', yddfp%IEXTERN, 0_jpim)
clmodel = 'CMODEL='
ival = 1_jpim
CALL faregu (kunit, clmodel, ival, 0_jpim)
yddfp%CMODEL = clmodel(8:)

CALL faregu (kunit, 'IDCEN', yddfp%NIDCEN, 0_jpim)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUP1',1,zhook_handle)

END SUBROUTINE fadup1

SUBROUTINE fadup2 (YDFA, YDDFP, KUNIT, KERR)

! Create FA library and re-open the file

TYPE(fa_com)                     :: YDFA
TYPE(fadup_params), INTENT (IN)  :: YDDFP
INTEGER (KIND=JPIM),INTENT (IN)  :: KUNIT
INTEGER (KIND=JPIM),INTENT (OUT) :: KERR

INTEGER (KIND=JPIM) :: INBARP, INBARI
REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUP2',0,zhook_handle)

inbarp = 0
inbari = 0

CALL new_fa (ydfa, kerr,   yddfp%IPXTRO, yddfp%IPXLAT, &
&            yddfp%IPXNIV, yddfp%IPNXFA, yddfp%IPNXCA)

ydfa%NULOUT     = yddfp%IULOUT_FA
ydfa%LFI%NULOUT = yddfp%IULOUT_LFI
ydfa%NIDCEN     = yddfp%NIDCEN

CALL fagiot_mt (ydfa,                                       &
&               yddfp%INGRIB, yddfp%INBPDG, yddfp%INBCSP,   &
&               yddfp%ISTRON, yddfp%IPUILA, yddfp%IDMOPL)

CALL facade_mt (ydfa,                                                   &
&               yddfp%CNOMC,  yddfp%ITYPTR, yddfp%ZSLAPO, yddfp%ZCLOPO, &
&               yddfp%ZSLOPO, yddfp%ZCODIL, yddfp%ITRONC, yddfp%INLATI, &
&               yddfp%INXLON, yddfp%INLOPA, yddfp%INOZPA, yddfp%ZSINLA, &
&               yddfp%INIVER, yddfp%ZREFER, yddfp%ZAHYBR, yddfp%ZBHYBR, &
&               yddfp%LGARD)

IF (yddfp%LOUVR) THEN
  CALL lfiafm_mt (ydfa%LFI, kerr, kunit, yddfp%IFACT)
  CALL faitou_mt (ydfa, kerr, kunit, yddfp%LNOMM, yddfp%CNOMF,          &
&                 yddfp%CSTTU, yddfp%LERFA, yddfp%LIMST, yddfp%INIMES,  &
                  inbarp, inbari, yddfp%CNOMC)
ELSE
  CALL fanouv_mt (ydfa, kerr, kunit, yddfp%LNOMM, yddfp%CNOMF,          &
&                 yddfp%CSTTU, yddfp%LERFA, yddfp%LIMST, yddfp%INIMES,  &
&                 inbarp, inbari, yddfp%CNOMC)
ENDIF

IF (.NOT. yddfp%LOUVR) THEN
  CALL fandax_mt (ydfa, kerr, kunit, yddfp%IDATEF)
ENDIF


ydfa%XLAP1D  => yddfp%XLAP1D
ydfa%XLAP1DA => yddfp%XLAP1DA
ydfa%XLAP2D  => yddfp%XLAP2D
ydfa%XLAP2DA => yddfp%XLAP2DA
ydfa%LIXLAP = &
      & .NOT.(ASSOCIATED (ydfa%XLAP1D)  &
      & .AND. ASSOCIATED (ydfa%XLAP1DA) &
      & .AND. ASSOCIATED (ydfa%XLAP2D)  &
      & .AND. ASSOCIATED (ydfa%XLAP2DA))

CALL faregu_mt (ydfa, kunit, 'EXTERN', yddfp%IEXTERN, 1_jpim)
CALL faregu_mt (ydfa, kunit, 'CMODEL='//trim(yddfp%CMODEL), 1_jpim, 1_jpim)
CALL faregu_mt (ydfa, kunit, 'IDCEN', yddfp%NIDCEN, 1_jpim)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUP2',1,zhook_handle)

END SUBROUTINE fadup2

SUBROUTINE fadupn1 (YDDFP, KUNIT)
USE oml_mod, ONLY : oml_num_threads

type(fadup_params), POINTER     :: yddfp(:)
INTEGER (KIND=JPIM), INTENT (IN) :: KUNIT

INTEGER (KIND=JPIM) :: NTID, ITID

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN1',0,zhook_handle)

ntid = oml_num_threads()

ALLOCATE (yddfp(ntid))

DO itid = 1, ntid
  CALL fadupu1 (yddfp(itid), kunit)
ENDDO

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN1',1,zhook_handle)

END SUBROUTINE fadupn1

SUBROUTINE fadupn2 (YDFA, YDDFP, KUNIT)
USE oml_mod, ONLY : oml_my_thread
USE fa_mod, ONLY : fa_com_default, fa_com

type(fa_com),       POINTER     :: ydfa
type(fadup_params), POINTER     :: yddfp(:)
INTEGER (KIND=JPIM), INTENT (IN) :: KUNIT

INTEGER (KIND=JPIM) :: ITID

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN2',0,zhook_handle)

itid = oml_my_thread()

ALLOCATE (ydfa)

CALL fadupu2 (ydfa, yddfp(itid), kunit)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN2',1,zhook_handle)

END SUBROUTINE fadupn2

SUBROUTINE fadupn3 (YDFA, YDDFP, KUNIT)
USE oml_mod, ONLY : oml_my_thread

type(fa_com),       POINTER     :: ydfa 
type(fadup_params), POINTER     :: yddfp(:)
INTEGER (KIND=JPIM), INTENT (IN) :: KUNIT

INTEGER (KIND=JPIM) :: IREP
INTEGER (KIND=JPIM) :: ITID
REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN3',0,zhook_handle)

itid = oml_my_thread()

IF (yddfp(itid)%LOUVR) THEN
  CALL fairme_mt (ydfa, irep, kunit, 'KEEP')
ELSE
  CALL fairno_mt (ydfa, irep, kunit, 'KEEP')
ENDIF

CALL fadupu3 (ydfa, yddfp(itid))

DEALLOCATE (ydfa)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN3',1,zhook_handle)

END SUBROUTINE fadupn3

SUBROUTINE fadupn4 (YDDFP)
USE oml_mod, ONLY : oml_num_threads

type(fadup_params), POINTER :: yddfp(:)

INTEGER (KIND=JPIM) :: NTID, ITID

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN4',0,zhook_handle)

ntid = oml_num_threads()

DO itid = 1, ntid
  CALL fadupu4 (yddfp(itid))
ENDDO

DEALLOCATE (yddfp)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPN4',1,zhook_handle)

END SUBROUTINE fadupn4

SUBROUTINE fadupu1 (YDDFP, KUNIT)
USE fa_mod, ONLY : fa_com_default
USE lfimod, ONLY : lficom

type(fadup_params), INTENT (OUT) :: yddfp
INTEGER (KIND=JPIM), INTENT (IN)  :: KUNIT

INTEGER (KIND=JPIM) :: IERR

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU1',0,zhook_handle)

CALL fadup1 (fa_com_default, yddfp, kunit, ierr)

yddfp%IPNXFA = 1
yddfp%IPNXCA = 1
yddfp%LGARD  = .false.

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU1',1,zhook_handle)

END SUBROUTINE fadupu1

SUBROUTINE fadupu2 (YDFA, YDDFP, KUNIT)
USE lfimod, ONLY : new_lfi

type(fa_com)                    :: ydfa
type(fadup_params), INTENT (IN) :: yddfp
INTEGER (KIND=JPIM), INTENT (IN) :: KUNIT

INTEGER (KIND=JPIM) :: IERR

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU2',0,zhook_handle)

ALLOCATE (ydfa%LFI)

CALL new_lfi (ydfa%LFI, ierr, kpnxfi=yddfp%IFACT)

CALL fadup2 (ydfa, yddfp, kunit, ierr)
ydfa%LOPENMP = .false.


IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU2',1,zhook_handle)

END SUBROUTINE fadupu2

SUBROUTINE fadupu3 (YDFA, YDDFP)
USE lfimod, ONLY : free_lfi
USE fa_mod, ONLY : free_fa

type(fa_com)                       :: ydfa
type(fadup_params), INTENT (INOUT) :: yddfp

INTEGER (KIND=JPIM) :: IERR

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU3',0,zhook_handle)

IF (ASSOCIATED (ydfa%XLAP1D,  yddfp%XLAP1D))  ydfa%XLAP1D  => null()
IF (ASSOCIATED (ydfa%XLAP1DA, yddfp%XLAP1DA)) ydfa%XLAP1DA => null()
IF (ASSOCIATED (ydfa%XLAP2D,  yddfp%XLAP2D))  ydfa%XLAP2D  => null()
IF (ASSOCIATED (ydfa%XLAP2DA, yddfp%XLAP2DA)) ydfa%XLAP2DA => null()
ydfa%LIXLAP = .true.

CALL free_fa (ydfa, ierr)
CALL free_lfi (ydfa%LFI, ierr)
DEALLOCATE (ydfa%LFI)
NULLIFY (ydfa%LFI)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU3',1,zhook_handle)

END SUBROUTINE fadupu3

SUBROUTINE fadupu4 (YDDFP)

type(fadup_params), INTENT (INOUT) :: yddfp

REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU4',0,zhook_handle)

DEALLOCATE (yddfp%INLOPA, yddfp%INOZPA, yddfp%ZSINLA, &
&           yddfp%ZAHYBR, yddfp%ZBHYBR, yddfp%IDATEF)

NULLIFY (yddfp%INLOPA, yddfp%INOZPA, yddfp%ZSINLA,  &
&        yddfp%ZAHYBR, yddfp%ZBHYBR, yddfp%IDATEF)

NULLIFY (yddfp%XLAP1D, yddfp%XLAP1DA, yddfp%XLAP2D, yddfp%XLAP2DA)

IF (lhook) CALL dr_hook ('FADUP_MOD:FADUPU4',1,zhook_handle)

END SUBROUTINE fadupu4

END MODULE fadup_mod