fatran.F90

Go to the documentation of this file.

! Nov-2012 P. Marguinaud Use local INDIRECT array
! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fatran_fort                                            &
&                     (fa,  krep,  knumer,  pchame, pchams, ldopt )
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme du logiciel de Fichiers ARPEGE permettant la
!      TRANsposition d'un champ spectral ARPEGE ou ALADIN,
!      d'un rangement des coeff selon le MODELE vers un rangement
!      des coeff selon FA+GRIB_version0 et inversement.
!
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KNUMER (Entree) ==> Rang de l'unite logique;
!    ( Tableau ) PCHAME (Entree) ==> Valeurs du champ a transposer;
!    ( Tableau ) PCHAMS (Sortie) ==> Valeurs du champ transpose;
!                LDOPT   (Entree) ==> Option de transposition;
!                                    si .TRUE.  alors PCHAME range comme MODELE
!                                                     (soit "verticalement")
!                                                     PCHAMS range comme FA-GRIB0
!                                                     (soit "horizontalement")
!                                    si .FALSE. alors PCHAME range comme FA-GRIB0
!                                                     PCHAMS range comme MODELE
!*
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER
!
LOGICAL LDOPT
!
REAL (KIND=JPDBLR) PCHAME(*), PCHAMS(*)
!
INTEGER (KIND=JPLIKB) JN, JM, J, INDEX, ILOW, IHIGH
INTEGER (KIND=JPLIKB) IRANGC, IRANG
INTEGER (KIND=JPLIKB) INIMES, ITRONC, IMSMAX
INTEGER (KIND=JPLIKB), ALLOCATABLE :: IND(:,:)
INTEGER (KIND=JPLIKB), ALLOCATABLE :: INDIRECT(:)
!
LOGICAL LLMLAM
!
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!
!
!
!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FATRAN_MT',0,zhook_handle)
krep=0
CALL fanumu_fort                 &
&               (fa, knumer,irang)
!
IF (irang.EQ.0) THEN
  krep=-51
  GOTO 1001
ENDIF
irangc=fa%FICHIER(irang)%NUCADR
llmlam=fa%CADRE(irangc)%LIMLAM
itronc=fa%CADRE(irangc)%MTRONC
IF (llmlam) THEN
  imsmax = fa%CADRE(irangc)%NOMPAR(2)
ENDIF

!
! Initialisation de l'indirection pour IRANGC, si ce n'est pas deja fait.
! Si ARPEGE, INDIRECT(J,IRANGC)=INDEX signifie que les indices J dans
!   le tableau "FA+GRIB0" et INDEX dans le tableau "modele ARPEGE"
!    designent un meme coeff spectral.
! Si Aladin, INDIRECT(JM*(ITRONC+1)+JN+1,IRANGC)=J signifie que l'indice
!   J dans le tableau "FA+GRIB0" est le premier coeff associe au couple (JM,JN)
!   ou JM est le nombre d'onde zonal et JN le nombre d'onde meridien.
!   4 coeff spectraux sont associes a chaque couple (JM,JN) car JM varie
!   de 0 a IMSMAX et JN varie de 0 a ITRONC (soit 1/4 de l'ellipse).
!
!  CAS ARPEGE
!
IF (.NOT.llmlam) THEN
  ALLOCATE (ind(0:itronc,-itronc:itronc))
  ALLOCATE (indirect((itronc+1)**2))
  DO jn=0,itronc
    ilow=jn**2+1
    ihigh=(jn+1)**2
    jm=-jn-1
    DO j=ilow,ihigh
      jm=jm+1
      ind(jn,jm)=j
    ENDDO
  ENDDO
!
  index=-1
  DO jm=0,itronc
  DO jn=jm,itronc
    index=index+2
    indirect(ind(jn, jm))=index
    IF (jm.NE.0) THEN
      indirect(ind(jn,-jm))=index+1
    ENDIF
  ENDDO
  ENDDO
  DEALLOCATE (ind)
ENDIF
!
!  CAS ALADIN
!
IF (llmlam) THEN
  ALLOCATE (indirect((itronc+1)**2))
  DO jn=0,itronc
  DO j=fa%CADRE(irangc)%NOZPAR(2*jn+3), fa%CADRE(irangc)%NOZPAR(2*jn+4), 4
    jm=(j-fa%CADRE(irangc)%NOZPAR(2*jn+3)) / 4
    indirect(jm*(itronc+1)+jn+1) = j
  ENDDO
  ENDDO
ENDIF
!**
!     2.  -  TRANSPOSITION DES DONNEES
!-----------------------------------------------------------------------
!
!  CAS ALADIN
!
IF (llmlam) THEN
    IF (ldopt) THEN
! PCHAME range comme MODELE (soit "verticalement")
!
    DO jm=0,imsmax
    DO index=fa%CADRE(irangc)%NOMPAR(2*jm+3), fa%CADRE(irangc)%NOMPAR(2*jm+4), 4
      jn = (index-fa%CADRE(irangc)%NOMPAR(2*jm+3)) / 4
      j  = indirect(jm*(itronc+1)+jn+1)
      pchams(j  )=pchame(index  )  
      pchams(j+1)=pchame(index+1)
      pchams(j+2)=pchame(index+2)
      pchams(j+3)=pchame(index+3)
    ENDDO
    ENDDO
  ELSE
! PCHAME range comme FA+GRIB0 (soit "horizontalement")
!
    DO jm=0,imsmax
    DO index=fa%CADRE(irangc)%NOMPAR(2*jm+3), fa%CADRE(irangc)%NOMPAR(2*jm+4), 4
      jn = (index-fa%CADRE(irangc)%NOMPAR(2*jm+3)) / 4
      j  = indirect(jm*(itronc+1)+jn+1)
      pchams(index  )=pchame(j  )  
      pchams(index+1)=pchame(j+1)
      pchams(index+2)=pchame(j+2)
      pchams(index+3)=pchame(j+3)
    ENDDO
    ENDDO
  ENDIF
ELSE
!
!  CAS ARPEGE
!
!  1/ Passage du rangement des coeff. spectraux du type modele ARPEGE
!  a celui de FA associe a GRIB version0 (et pas associe a GRIBEX qui
!  reprend la structure de tableau de ARPEGE).
!
  IF (ldopt) THEN
    DO jn=0,itronc
      ilow=jn**2+1
      ihigh=(jn+1)**2
      DO j=ilow,ihigh
        pchams(j)=pchame(indirect(j))
      ENDDO
    ENDDO
!
!  2/ Passage du rangement des coeff. spectraux du type FA associe
!  a GRIB version0 (et pas associe a GRIBEX qui reprend la structure de
!  tableau de ARPEGE) a celui du type modele ARPEGE.
!
  ELSE
!  Initialisation de la partie "JM=0" a zero, pour y introduire
!  ensuite uniquement les coeff reels correspondant dans PCHAME
!  (les coeff imaginaires etant donc crees et mis a zero).
    pchams(1:2*(itronc+1))=0._jpdblr
!
    DO jn=0,itronc
      ilow=jn**2+1
      ihigh=(jn+1)**2
      DO j=ilow,ihigh
        pchams(indirect(j))=pchame(j)
      ENDDO
    ENDDO
  ENDIF
ENDIF
!
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE

IF (ALLOCATED (indirect)) DEALLOCATE (indirect)

llfata=llmoer(krep,irang)
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(irang)
ENDIF
!
IF (inimes.EQ.0)  THEN 
  IF (lhook) CALL dr_hook('FATRAN_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FATRAN'
!
WRITE (unit=clmess,fmt='(''KREP='',I4,'', IRANG='',I4, &
&         '', LDOPT='',L2)')  krep, irang, ldopt
CALL faipar_fort                                     &
&               (fa, knumer,inimes,krep,llfata,clmess, &
&               clnspr,clnspr,.false.)
!
IF (lhook) CALL dr_hook('FATRAN_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"
#include "facom2.ixnvms.h"

END SUBROUTINE fatran_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE fatran64                             &
&           (krep, knumer, pchame, pchams, ldopt)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KREP                                   !   OUT
INTEGER (KIND=JPLIKB)  KNUMER                                 ! IN   
REAL (KIND=JPDBLR)     PCHAME     (*)                         ! IN   
REAL (KIND=JPDBLR)     PCHAMS     (*)                         !   OUT
LOGICAL                LDOPT                                  ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fatran_fort                                    &
&           (fa, krep, knumer, pchame, pchams, ldopt)

END SUBROUTINE fatran64

SUBROUTINE fatran                               &
&           (krep, knumer, pchame, pchams, ldopt)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
REAL (KIND=JPDBLR)     PCHAME     (*)                         ! IN   
REAL (KIND=JPDBLR)     PCHAMS     (*)                         !   OUT
LOGICAL                LDOPT                                  ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fatran_mt                                      &
&           (fa, krep, knumer, pchame, pchams, ldopt)

END SUBROUTINE fatran

SUBROUTINE fatran_mt                                &
&           (fa, krep, knumer, pchame, pchams, ldopt)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
REAL (KIND=JPDBLR)     PCHAME     (*)                         ! IN   
REAL (KIND=JPDBLR)     PCHAMS     (*)                         !   OUT
LOGICAL                LDOPT                                  ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)

CALL fatran_fort                                    &
&           (fa, irep, inumer, pchame, pchams, ldopt)

krep       = int(      irep, jplikm)

END SUBROUTINE fatran_mt

!INTF KREP            OUT                               
!INTF KNUMER        IN                                  
!INTF PCHAME        IN    DIMS=*                        
!INTF PCHAMS          OUT DIMS=*                        
!INTF LDOPT         IN