fareor.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fareor_fort                                             &
&                     (fa,  krep, knumer, pchamm, pchamf, ldftom)
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme de REORDONNANCEMENT des coefficients d'un champ horizontal spectral
!      destine a etre ecrit sur un fichier ARPEGE/ALADIN, ou bien qui vient
!      d'etre lu.
!
!**
!    Arguments : KREP   (Sortie)        ==> Code-reponse du sous-programme;
!                KNUMER (Entree)        ==> Numero de l'unite logique;
!    ( Tableau ) PCHAMM (Entree/Sortie) ==> Valeurs du champ, rangement modele
!    ( Tableau ) PCHAMF (Entree/Sortie) ==> Valeurs du champ, rangement fichier
!                LDFTOM (Entree)        ==> Fichier vers modele (T), modele vers
!                                           fichier (F)
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER
!
REAL (KIND=JPDBLR) PCHAMM (*), PCHAMF (*)
!
LOGICAL LDFTOM
!
INTEGER (KIND=JPLIKB) IRANG, IRANGC, INIMES
INTEGER (KIND=JPLIKB) ISMAX
INTEGER (KIND=JPLIKB), POINTER :: IISMAX (:), IDIM0GG (:)
CHARACTER(LEN=FA%JPLSPX) CLNSPR
CHARACTER(LEN=FA%JPLMES) CLMESS 
LOGICAL LLMLAM, LLFATA, LLRLFI

REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FAREOR_MT',0,zhook_handle)

krep = 0
llrlfi = .false.

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

ismax   =  fa%CADRE(irangc)%NSMAX     
iismax  => fa%CADRE(irangc)%NISMAX     
idim0gg => fa%CADRE(irangc)%NDIM0GG

IF (llmlam) THEN
  CALL fareor_lam
ELSE
  CALL fareor_glo
ENDIF

1001 CONTINUE

llfata=llmoer(krep,irang)

IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(irang)
ENDIF

IF (.NOT.llfata.AND.inimes.NE.2)  THEN 
  IF (lhook) CALL dr_hook('FAREOR_MT',1,zhook_handle)
  RETURN
ENDIF

clnspr='FAREOR'

WRITE (unit=clmess,fmt='(''KREP='',I5,'', KNUMER='',I3)') &
&   krep,knumer

CALL faipar_fort                                       &
&               (fa, knumer,inimes,krep,llfata,clmess, &
&                clnspr, '',llrlfi)

IF (lhook) CALL dr_hook('FAREOR_MT',1,zhook_handle)

CONTAINS

SUBROUTINE fareor_lam

INTEGER (KIND=JPLIKB) :: II, ISP, JM, JN

ii=0
IF (ldftom) THEN
  DO jn=0,ismax
    DO jm=0,iismax(jn)
      isp=idim0gg(jm)+4*jn
      ii=ii+4
      pchamm(isp:isp+3)=pchamf(ii-3:ii)
    ENDDO
  ENDDO
ELSE
  DO jn=0,ismax  
    DO jm=0,iismax(jn)
      isp=idim0gg(jm)+4*jn
      ii=ii+4
      pchamf(ii-3:ii)=pchamm(isp:isp+3)
    ENDDO
  ENDDO
ENDIF

END SUBROUTINE fareor_lam

SUBROUTINE fareor_glo

INTEGER(KIND=JPLIKB) :: II, IM, ISP, JM, JN

IF (ldftom) THEN
  ii=0
  DO jn=0,ismax
    DO jm=-jn,-1
      isp=idim0gg(-jm)+(jn+jm)*2 +1
      ii = ii + 1
      pchamm(isp)=pchamf(ii)
    ENDDO
    isp=idim0gg(0)+jn*2
    ii = ii + 1
    pchamm(isp)=pchamf(ii)
    pchamm(isp+1)=0.0_jprb
    DO jm=1,jn
      isp=idim0gg(jm)+(jn-jm)*2
      ii = ii + 1
      pchamm(isp)=pchamf(ii)
    ENDDO
  ENDDO
ELSE
  ii=0
  DO jn=0,ismax
    DO jm=-jn,jn
      im=abs(jm)
      IF (jm < 0) THEN
        isp=idim0gg(im)+(jn-im)*2 +1
      ELSE
        isp=idim0gg(im)+(jn-im)*2
      ENDIF
      ii = ii + 1
      pchamf(ii)=pchamm(isp)
    ENDDO
  ENDDO
ENDIF

END SUBROUTINE fareor_glo


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

END SUBROUTINE fareor_fort

! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE fareor64                                      &
&                     (krep, knumer, pchamm, pchamf, ldftom)
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)     PCHAMM     (*)                         ! INOUT
REAL (KIND=JPDBLR)     PCHAMF     (*)                         ! INOUT
LOGICAL                LDFTOM                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fareor_fort                                             &
&                     (fa,  krep, knumer, pchamm, pchamf, ldftom)

END SUBROUTINE fareor64

SUBROUTINE fareor                                        &
&                     (krep, knumer, pchamm, pchamf, ldftom)
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   
INTEGER (KIND=JPDBLR)  PCHAMM     (*)                         ! INOUT
INTEGER (KIND=JPDBLR)  PCHAMF     (*)                         ! INOUT
LOGICAL                LDFTOM                                 ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL fareor_mt                                                 &
&                     (fa,  krep, knumer, pchamm, pchamf, ldftom)

END SUBROUTINE fareor

SUBROUTINE fareor_mt                                         &
&                     (fa, krep, knumer, pchamm, pchamf, ldftom)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
TYPE(fa_com)           FA
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPDBLR)  PCHAMM     (*)                         ! INOUT
INTEGER (KIND=JPDBLR)  PCHAMF     (*)                         ! INOUT
LOGICAL                LDFTOM                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)

CALL fareor_fort                                             &
&                     (fa, irep, inumer, pchamm, pchamf, ldftom)

krep       = int(      irep, jplikm)

END SUBROUTINE fareor_mt

!INTF KREP            OUT                                                              
!INTF KNUMER        IN                                                                 
!INTF PCHAMM        INOUT DIMS=*                         KIND=JPDBLR                   
!INTF PCHAMF        INOUT DIMS=*                         KIND=JPDBLR                   
!INTF LDCOSP        IN