mode_prep_ctl.F90

Go to the documentation of this file.

MODULE mode_prep_ctl

!**** *MODE_PREP_CTL*  - Control PREP structure

!     Author. 
!     ------- 
!      Philippe Marguinaud *METEO FRANCE* 
!      Original : 01-10-2014

!     Description.
!     ------------
!     This module implements a structure and methods to control PREP execution,
!     retrieve fields to be interpolated so that an external program may
!     interpol the fields itself (Fullpos), and pass back interpolated fields to
!     PREP.

USE modi_abor1_sfx

IMPLICIT NONE

TYPE prep_ctl_fld
  CHARACTER (LEN=32) :: clname = '', cltype = '', clmask = ''
  REAL, POINTER :: zfld2 (:,:)   => null ()
  REAL, POINTER :: zfld3 (:,:,:) => null ()
  type(prep_ctl_fld), POINTER :: next => null()
  type(prep_ctl_fld), POINTER :: prev => null()
END TYPE prep_ctl_fld

TYPE prep_ctl
  LOGICAL :: lstep0 = .false. ! PREP step 0 (count fields to be interpolated)
  LOGICAL :: lstep1 = .false. ! PREP step 1 (retrieve fields to be interpolated)
  LOGICAL :: lstep2 = .false. ! PREP step 2 (pass interpolated fields to PREP and finish)

  LOGICAL :: lpart1 = .true.  ! Invoke PREP_*_EXTERN routines
  LOGICAL :: lpart2 = .false. ! Retrieve or pass back interpolated fields from/to PREP
  LOGICAL :: lpart3 = .true.  ! Do interpolations
  LOGICAL :: lpart4 = .false. ! Unused for now
  LOGICAL :: lpart5 = .true.  ! Post-processing after interpolations
  LOGICAL :: lpart6 = .true.  ! Post-processing after interpolations (higher level)
  type(prep_ctl_fld), POINTER :: head => null(), tail => null()
END TYPE

INTERFACE prep_ctl_int_part2
  MODULE PROCEDURE prep_ctl_int_part2_2, prep_ctl_int_part2_3
END INTERFACE

INTERFACE prep_ctl_int_part4
  MODULE PROCEDURE prep_ctl_int_part4_2, prep_ctl_int_part4_3
END INTERFACE

CONTAINS

LOGICAL FUNCTION prep_ctl_can (YDCTL)

! Returns true if we are not in a 2-part PREP

type(prep_ctl), INTENT (INOUT) :: ydctl

type(prep_ctl) :: ylctl

prep_ctl_can = (ydctl%LSTEP0 .EQV. ylctl%LSTEP0) .AND. (ydctl%LSTEP1 .EQV. ylctl%LSTEP1) .AND. &
             & (ydctl%LSTEP2 .EQV. ylctl%LSTEP2) .AND. (ydctl%LPART1 .EQV. ylctl%LPART1) .AND. &
             & (ydctl%LPART1 .EQV. ylctl%LPART1) .AND. (ydctl%LPART2 .EQV. ylctl%LPART2) .AND. &
             & (ydctl%LPART3 .EQV. ylctl%LPART3) .AND. (ydctl%LPART4 .EQV. ylctl%LPART4) .AND. &
             & (ydctl%LPART5 .EQV. ylctl%LPART5) .AND. (ydctl%LPART6 .EQV. ylctl%LPART6) 
  

END FUNCTION prep_ctl_can

SUBROUTINE prep_ctl_count (YDCTL, KCOUNT)

! Reckon the number of 2D fields in YDCTL

type(prep_ctl),     INTENT (INOUT) :: ydctl
INTEGER,             INTENT (OUT)   :: KCOUNT

type(prep_ctl_fld), POINTER        :: ylcfl

kcount = 0

ylcfl => ydctl%HEAD
DO WHILE (ASSOCIATED (ylcfl))
  IF (ASSOCIATED (ylcfl%ZFLD2)) THEN
    kcount = kcount + SIZE (ylcfl%ZFLD2, 2)
  ELSEIF (ASSOCIATED (ylcfl%ZFLD3)) THEN
    kcount = kcount + SIZE (ylcfl%ZFLD3, 2) * SIZE (ylcfl%ZFLD3, 3)
  ENDIF
  ylcfl => ylcfl%NEXT
ENDDO

END SUBROUTINE prep_ctl_count

SUBROUTINE prep_ctl_free (YDCTL)

! Free a whole PREP_CTL structure

type(prep_ctl),     INTENT (INOUT) :: ydctl

type(prep_ctl_fld), POINTER        :: ylcfl

ylcfl => ydctl%HEAD
DO WHILE (ASSOCIATED (ylcfl))
  IF (ASSOCIATED (ylcfl%ZFLD2)) THEN
    DEALLOCATE (ylcfl%ZFLD2)
  ELSEIF (ASSOCIATED (ylcfl%ZFLD3)) THEN
    DEALLOCATE (ylcfl%ZFLD3)
  ENDIF
  ylcfl => ylcfl%NEXT
  DEALLOCATE (ydctl%HEAD)
  ydctl%HEAD => ylcfl
ENDDO

NULLIFY (ydctl%HEAD, ydctl%TAIL)

END SUBROUTINE prep_ctl_free

SUBROUTINE prep_ctl_push (YDCTL, YDCFL)

! Add a new set of fields

type(prep_ctl),     INTENT (INOUT) :: ydctl
type(prep_ctl_fld), POINTER        :: ydcfl

IF (ASSOCIATED (ydctl%TAIL)) THEN
  ydctl%TAIL%NEXT => ydcfl
  ydcfl%PREV => ydctl%TAIL
  ydctl%TAIL => ydcfl
ELSE
  ydctl%HEAD => ydcfl
  ydctl%TAIL => ydcfl
ENDIF

NULLIFY (ydcfl)

END SUBROUTINE prep_ctl_push

SUBROUTINE prep_ctl_shift (YDCTL, YDCFL)

! Get back a set of fields

type(prep_ctl),     INTENT (INOUT) :: ydctl
type(prep_ctl_fld), POINTER        :: ydcfl

ydcfl => ydctl%HEAD

IF (.NOT. ASSOCIATED (ydcfl)) THEN
  CALL abor1_sfx ('PREP_CTL_SHIFT: ATTEMPT TO SHIFT EMPTY FIELD LIST')
ENDIF

ydctl%HEAD => ydcfl%NEXT

IF (ASSOCIATED (ydctl%HEAD)) THEN
  ydctl%HEAD%PREV => null()
ENDIF

END SUBROUTINE prep_ctl_shift

SUBROUTINE prep_ctl_int_part2_2 (YDCTL, CDSURF, CDTYPE, CDMASK, PFIELDIN)

! Retrieve/pass back fields

type(prep_ctl),   INTENT (INOUT) :: ydctl
 CHARACTER (LEN=*), INTENT (IN)    :: CDSURF
 CHARACTER (LEN=*), INTENT (IN)    :: CDTYPE
 CHARACTER (LEN=*), INTENT (IN)    :: CDMASK
REAL,              POINTER        :: PFIELDIN (:,:)

type(prep_ctl_fld), POINTER :: ylcfl

INTEGER :: IREP

IF (ydctl%LPART2) THEN
  IF (ydctl%LSTEP0 .OR. ydctl%LSTEP1) THEN
    ALLOCATE (ylcfl)
    ylcfl%CLTYPE = cdtype
    ylcfl%CLNAME = cdsurf
    ylcfl%CLMASK = cdmask
    ylcfl%ZFLD2 => pfieldin
    NULLIFY (pfieldin)
    CALL prep_ctl_push (ydctl, ylcfl)
  ELSEIF (ydctl%LSTEP2) THEN
    CALL prep_ctl_shift (ydctl, ylcfl)
    IF (ylcfl%CLNAME /= cdsurf .OR. ylcfl%CLTYPE /= cdtype) THEN
      CALL abor1_sfx ('PREP_CTL_INT_PART2: FIELD MISMATCH: EXPECTED '&
                    &//trim(cdsurf)//'/'//trim(cdtype)//', GOT '// &
                    &trim(ylcfl%CLNAME)//'/'//trim(ylcfl%CLTYPE))
    ENDIF
    pfieldin => ylcfl%ZFLD2
    NULLIFY (ylcfl%ZFLD2)
    DEALLOCATE (ylcfl)
  ENDIF
ENDIF

END SUBROUTINE prep_ctl_int_part2_2

SUBROUTINE prep_ctl_int_part4_2 (YDCTL, CDSURF, CDTYPE, CDMASK, PFIELDIN, PFIELDOUT)

type(prep_ctl),   INTENT (INOUT) :: ydctl
 CHARACTER (LEN=*), INTENT (IN)    :: CDSURF
 CHARACTER (LEN=*), INTENT (IN)    :: CDTYPE
 CHARACTER (LEN=*), INTENT (IN)    :: CDMASK
REAL,              POINTER        :: PFIELDIN  (:,:)
REAL,              POINTER        :: PFIELDOUT (:,:)

type(prep_ctl_fld), POINTER :: ylcfl
INTEGER :: IREP, ILONG, IPOSEX
INTEGER (8) :: JDIM (2)

IF (ydctl%LPART4) THEN
ENDIF

END SUBROUTINE prep_ctl_int_part4_2

SUBROUTINE prep_ctl_int_part2_3 (YDCTL, CDSURF, CDTYPE, CDMASK, PFIELDIN)

! Retrieve/pass back fields

type(prep_ctl),   INTENT (INOUT) :: ydctl
 CHARACTER (LEN=*), INTENT (IN)    :: CDSURF
 CHARACTER (LEN=*), INTENT (IN)    :: CDTYPE
 CHARACTER (LEN=*), INTENT (IN)    :: CDMASK
REAL,              POINTER        :: PFIELDIN (:,:,:)

type(prep_ctl_fld), POINTER :: ylcfl

INTEGER :: IREP

IF (ydctl%LPART2) THEN
  IF (ydctl%LSTEP0 .OR. ydctl%LSTEP1) THEN
    ALLOCATE (ylcfl)
    ylcfl%CLTYPE = cdtype
    ylcfl%CLNAME = cdsurf
    ylcfl%CLMASK = cdmask
    ylcfl%ZFLD3 => pfieldin
    NULLIFY (pfieldin)
    CALL prep_ctl_push (ydctl, ylcfl)
  ELSEIF (ydctl%LSTEP2) THEN
    CALL prep_ctl_shift (ydctl, ylcfl)
    IF (ylcfl%CLNAME /= cdsurf .OR. ylcfl%CLTYPE /= cdtype) THEN
      CALL abor1_sfx ('PREP_CTL_INT_PART2: FIELD MISMATCH: EXPECTED '&
                    &//trim(cdsurf)//'/'//trim(cdtype)//', GOT '// &
                    &trim(ylcfl%CLNAME)//'/'//trim(ylcfl%CLTYPE))
    ENDIF
    pfieldin => ylcfl%ZFLD3
    NULLIFY (ylcfl%ZFLD3)
    DEALLOCATE (ylcfl)
  ENDIF
ENDIF

END SUBROUTINE prep_ctl_int_part2_3

SUBROUTINE prep_ctl_int_part4_3 (YDCTL, CDSURF, CDTYPE, CDMASK, PFIELDIN, PFIELDOUT)

type(prep_ctl),   INTENT (INOUT) :: ydctl
 CHARACTER (LEN=*), INTENT (IN)    :: CDSURF
 CHARACTER (LEN=*), INTENT (IN)    :: CDTYPE
 CHARACTER (LEN=*), INTENT (IN)    :: CDMASK
REAL,              POINTER        :: PFIELDIN  (:,:,:)
REAL,              POINTER        :: PFIELDOUT (:,:,:)

INTEGER :: IREP, ILONG, IPOSEX
INTEGER (8) :: JDIM (3)
type(prep_ctl_fld), POINTER :: ylcfl

IF (ydctl%LPART4) THEN
ENDIF

END SUBROUTINE prep_ctl_int_part4_3

END MODULE