facine.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
! Sep-2012 P. Marguinaud Fix uninitialized variables
SUBROUTINE facine_fort                                              &
&                     (fa,  krep,   krang,  cdnoma, pchamp, ldcosp, &
&                      pvalco, klongd, kb1par, ldundf, pundf)
USE fa_mod, ONLY : fa_com, jpniil, jpprcm
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!      PREPARATION (codage GRIB ou non) d'un CHAMP HORIZONTAL
!      destine a etre ecrit sur un fichier ARPEGE/ALADIN.
!       ( Codage Interne d'un (Nouveau ?) champ a Ecrire )
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KRANG  (Entree) ==> Rang de l'unite logique;
!                CDNOMA (Entree) ==> Nom d'article (prefabrique);
!    ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
!                LDCOSP (Entree) ==> Vrai si le champ est represente
!                                    par des coefficients spectraux;
!    ( Tableau ) PVALCO (Sortie) ==> Donnees destinees a l'ecriture;
!                KLONGD (Sortie) ==> Nombre de mots a ecrire;
!    ( Tableau ) KB1PAR (Entree+ ==> Image des parametres de la section
!                        Sortie)     1 de GRIB.
!*
!       En mode multi-taches, il doit y avoir verrouillage du fichier
!     concerne avant l'appel au sous-programme.
!
!     Modifications
!     -------------
!  Juin 2001, D. Paradis, DT/DSI/DEV:
!
!    -retrait du compactage lorsqu'il conduit a un article de longueur
!     superieure a celle obtenue sans le compactage (permet aussi de
!     dimensionner PVALCO a ILCHAM+2 sans risquer un debordement)
!
!  Avril 2004, D. Paradis, DT/DSI/DEV:
!
!    -declaration de ZCHAMP et ZCHAUX en ALLOCATABLE (gain memoire)
!
! January 2010 Trygve Aspelien & Ryad El Khatib : 
!    - workaround against memory leak on IBM
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG, KLONGD
!
REAL (KIND=JPDBLR) PCHAMP (*)
REAL (KIND=JPDBLD) PVALCO (*)
INTEGER (KIND=JPLIKB) KB1PAR (fa%jplb1p)
REAL (KIND=JPDBLR) PUNDF
!
LOGICAL LDCOSP, LDUNDF
!
CHARACTER CDNOMA*(*)
!
INTEGER (KIND=JPLIKB) ILCHAM, ISTRIA, IVALC1, IVALC2
INTEGER (KIND=JPLIKB) J, IDECAL, ICPACK, IPUILA
INTEGER (KIND=JPLIKB) ITRONC, IIND, ILOW, IHIGH, JTRON
INTEGER (KIND=JPLIKB) IDIMNC, ILDISP, INBITS, INBITSMAX
INTEGER (KIND=JPLIKB) IL, IADD, IRANGC, IARR, IILCHAM
INTEGER (KIND=JPLIKB) INMOCC, IERR, INIMES
INTEGER (KIND=JPLIKB) INUMER, ITRONC2, ILONGFA
INTEGER (KIND=JPLIKB) ILONGSEC, ILONGDATA
INTEGER (KIND=JPLIKB) ILONGD
!
INTEGER (KIND=JPLIKB) IB2PAR (fa%jplb2p)
!
LOGICAL LLARPE, LLMLAM
!
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA
REAL (KIND=JPDBLR) :: ZTEMP (2)
!
REAL (KIND=JPDBLR), ALLOCATABLE :: ZCHAMP (:), ZCHAUX (:)
REAL (KIND=JPDBLR) ZAVG
INTEGER (KIND=JPLIKB) IAVG

!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FACINE_MT',0,zhook_handle)
icpack=0
IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
  krep=-66
  GOTO 1001
ENDIF
!**
!     2.  -  FABRICATION DE L'ARTICLE A ECRIRE SUR LE FICHIER.
!-----------------------------------------------------------------------
!
ivalc1=fa%FICHIER(krang)%NFGRIB
llarpe=ivalc1.EQ.2
irangc=fa%FICHIER(krang)%NUCADR
llmlam=fa%CADRE(irangc)%LIMLAM
ib2par=0
!
!  Initialisation du nombre de valeurs du champ (ILCHAM)
!                 du type de champ (IVALC2): spectral/pdg
!                 du type de representation de donnees (IB2PAR(1))
!                 du nombre de bits utilises pour le compactage
!                 de la longueur (en mots de 64 bits) de l'enrobage de l'article
!                          FA (ILONGFA) + les donnees non compactees (en spectral)
!                 de la longueur (en octets) des sections 0, 1 et 5 du GRIB
!                          devant apparaitre dans l'article FA (ILONGSEC)
!                 de la longueur (en bits) de la section 4 du GRIB (ILONGDATA),
!                          devant etre un multiple de 16 bits.
!
IF (jpdbld == jpdblr) THEN
  inbitsmax = 64
ELSE
  inbitsmax = 32
ENDIF
!
! ILONGSEC= 4 (S0) + 24 (S1) + 4 (S5) pour le GRIB version 0
ilongsec=32
IF (ldcosp) THEN
!
  ivalc2=1
  inbits=min(fa%FICHIER(krang)%NBFCSP, inbitsmax)
!
  IF (llmlam) THEN
    ib2par(1)=34
    ilcham=fa%CADRE(irangc)%NSFLAM
    IF (ivalc1.GT.0) THEN
! calcul du nombre de coefficients non compactes ISTRIA
      icpack=fa%FICHIER(krang)%NSTROF
      itronc=fa%CADRE(irangc)%MTRONC
      itronc2=-fa%CADRE(irangc)%NTYPTR
      istria=4*(1+itronc+itronc2+(icpack*(icpack-1)/2))
!
      ilongfa=3+2*ivalc1+istria
!  Les 88 bits correspondent aux 11 octets d'enrobage GRIB V0 de la section 4
      ilongdata=(ilcham-istria)*inbits + 88
    ENDIF
  ELSE
    IF (ivalc1.EQ.-1) THEN
      ilcham=(1+fa%CADRE(irangc)%MTRONC)*(2+fa%CADRE(irangc)%MTRONC)
    ELSE
      ilcham=(1+fa%CADRE(irangc)%MTRONC)**2
    ENDIF
    ib2par(1)=80
    IF (ivalc1.GT.0) THEN
      icpack=fa%FICHIER(krang)%NSTROF
! calcul du nombre de coefficients non compactes IDIMNC
      idimnc=(1+icpack)**2
      ilongfa=3+2*ivalc1+idimnc
!  Les 144 bits correspondent aux 18 octets d'enrobage GRIB V0 de la section 4
      ilongdata=ilcham*inbits + idimnc*(32-inbits) + 144
    ENDIF
  ENDIF
!
ELSE
!
  ilcham=fa%CADRE(irangc)%NVAPDG
  ivalc2=0
  ib2par(1)=34
  inbits=min(fa%FICHIER(krang)%NBFPDG, inbitsmax)
  IF (ivalc1.GT.0) THEN
    ilongfa=1+2*ivalc1
!  Les 88 bits correspondent aux 11 octets d'enrobage GRIB V0 de la section 4
    ilongdata=ilcham*inbits + 88
  ENDIF
!
ENDIF
!
!  Retrait du compactage si celui-ci s'avere conduire
!  a un article plus long qu'en l'absence de compactage:
!
IF (ivalc1.GT.0) THEN
! Arrondi de ILONGDATA au premier multiple de 16 superieur ou egal
  ilongdata=16*(1+(ilongdata-1)/16)
! Calcul du nombre de mots (64 bits) de la partie GRIB
  ilongd=1+(ilongdata+8*ilongsec-1)/64
! On ajoute l'enrobage FA et les eventuelles donnees non compactees
  ilongd=ilongd+ilongfa
  IF (ilongd .GT. ((ilcham+jpprcm-1)/jpprcm+2)) THEN ! Should work both for simple & double precision
!          WRITE (FA%NULOUT,*)
!     S    '///// FACINE:  the packing of article ',CDNOMA,
!     S    ' is not done because it will generate'
!          WRITE (FA%NULOUT,*)
!     S    '         a size ( ',ILONGD,' words ) bigger than',
!     S    ' the one ( ',ILCHAM+2,' words ) obtained without packing.'
    ivalc1=0
!          WRITE (FA%NULOUT,*)
  ENDIF
ENDIF
!
IF (inbits == inbitsmax) THEN
  ivalc1 = 0
ENDIF
!
istria = 0
!
IF (ivalc1.EQ.-1.OR.ivalc1.EQ.0) THEN
!
!          Cas ou il n'y a aucun codage...
!     transfert du tableau d'entree a la suite des 2 valeurs
!     documentaires stockees ci-dessus dans PVALCO.
!
  IF (jpdblr == jpdbld) THEN
    DO j = 1, ilcham
      pvalco(2+j) = REAL (PCHAMP (J), JPDBLD)
    ENDDO
    klongd=2+ilcham
  ELSE
    DO j = 1, ilcham, 2
      ztemp(1) = pchamp(j+0)
      IF (j+1 <= ilcham) THEN
        ztemp(2) = pchamp(j+1)
      ELSE
        ztemp(2) = 0._jpdblr
      ENDIF
      pvalco(2+1+(j-1)/2) = transfer(ztemp(1:2), pvalco(2+1+(j-1)/2))
    ENDDO
    klongd=2+(ilcham+1)/2
  ENDIF
!
ELSE
!
!          Cas avec codage GRIB (standard ou non).
!
  ALLOCATE (zchamp(ilcham))
!
  idecal=1+2*ivalc1
  kb1par(1)=98
  kb1par(2)=1
  kb1par(3)=254
  kb1par(4)=0
  kb1par(5)=255
  kb1par(9)=mod(fa%FICHIER(krang)%MADATE(1),100_jplikb )
!
  DO j=2,fa%JPLDAT
  kb1par(8+j)=fa%FICHIER(krang)%MADATE(j)
  ENDDO
!
  ib2par(6)=2
  ipuila=fa%FICHIER(krang)%NPUFLA
  itronc=fa%CADRE(irangc)%MTRONC
!
  IF (ldcosp) THEN
!
!           Champ en coefficients spectraux... traitement particulier,
!     lie a la possibilite de compacter une (pseudo-)puissance de
!     laplacien du champ a la place du champ, de maniere a augmenter
!     la precision du champ en "aplanissant" le spectre.
!
    CALL facsim_fort (fa, krep,krang,pchamp,zchamp,ipuila,icpack)
    IF (fa%LFAMOP) THEN
      print *,'FACINE: puissance Dolby selectionnee ',ipuila
    ENDIF
    IF (krep.NE.0) GOTO 1001
    IF (llmlam) THEN
! Copy the elements to be compacted from ZCHAMP to a work array
! This is that part of the quarter-ellipse which is out of the triangle of no compacting.
! In addition, the axes of ellipse are also excluded because of zero-coefficients
      ALLOCATE (zchaux(ilcham))
      iind=0
!
      DO jtron=1,itronc
        ilow=2+2*jtron+1
        iadd=4* max(icpack+1-jtron,1_jplikb )
!
        DO j=fa%CADRE(irangc)%NOZPAR(ilow)+iadd, &
&                    fa%CADRE(irangc)%NOZPAR(ilow+1)
          iind=iind+1
          zchaux(iind)=zchamp(j)
        ENDDO
      ENDDO
! Number of elements in sub-triangle+axes:ISTRIA
      istria=ilcham-iind
      idimnc=0
    ELSE
      istria=idimnc
    ENDIF
!
    idecal=idecal+2
    ildisp=ilcham+2-idecal-(ivalc1-1)*istria
!
    IF (.NOT.llarpe) THEN
!
!            Recopie des coefficients spectraux "non compactes",
!     qui sont codes en fait sur 32 bits dans le cas standard de GRIB.
!
      DO j=1,idimnc
      zchamp(j)=pchamp(j)
      ENDDO
!
    ENDIF
!
  ELSE
!
!          Transfert du tableau d'entree dans un tableau local
!     de maniere a eviter l'ecrasement du tableau d'entree par "CODEGA".
!
    DO j=1,ilcham
    zchamp(j)=pchamp(j)
    ENDDO
!
!   Si des valeurs indefinies sont presentes, alors on les remplace 
!   par la moyenne des valeurs definies
!
    IF (ldundf) THEN
      zavg = 0._jpdblr
      iavg = 0
      DO j = 1, ilcham
        IF (pchamp(j) /= pundf) THEN
          zavg = zavg + pchamp(j)
          iavg = iavg + 1
        ENDIF
      ENDDO
      IF (iavg > 0) THEN
        zavg = zavg / iavg
      ELSE
        zavg = 0._jpdblr
      ENDIF
      DO j = 1, ilcham
        IF (pchamp(j) == pundf) THEN
          zchamp(j) = zavg
        ENDIF
      ENDDO
    ENDIF

!
    idimnc=0
    ildisp=ilcham+2-idecal
  ENDIF
!*
!     3.1 -  CODAGE GRIB PROPREMENT DIT.
!-----------------------------------------------------------------------
!
  iarr=0
!
  IF (ldcosp.AND.llmlam) THEN
    iilcham=ilcham-istria
    CALL facodega(zchaux,iilcham,inbits,fa%NBIMAC,kb1par,        &
&                 ib2par,fa%CADRE(irangc)%SFOHYB(1,0),2_jplikb , &
&                 pvalco(idecal+1),ildisp,inmocc,iarr,           &
&                 0_jplikb ,ipuila,ierr,pvalco(idecal-1),        &
&                 pvalco(idecal),llarpe)
  ELSE
    CALL facodega(zchamp,ilcham,inbits,fa%NBIMAC,kb1par,ib2par, &
&                 fa%CADRE(irangc)%SFOHYB(1,0),2_jplikb ,       &
&                 pvalco(idecal+1),ildisp,inmocc,iarr,icpack,   &
&                 ipuila,ierr,pvalco(idecal-1),pvalco(idecal),  &
&                 llarpe)
  ENDIF
!
  IF (ierr.NE.0) THEN
    krep=-200+ierr
    GOTO 1001
  ELSEIF (ldcosp) THEN
    pvalco(4)=transfer(icpack, pvalco(4))
    pvalco(5)=transfer(ipuila, pvalco(5))
!
    IF (llarpe) THEN
!*
!     3.2 -  TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES.
!-----------------------------------------------------------------------
!        (et non traites par CODEGA) en fin d'article.
!
      IF (llmlam) THEN
! Copy nonpacked part of kchamp (sub-triangle+axes) into zchaux
        iind=0
!
        DO jtron=0,itronc
          il=2+2*jtron+1
          ilow=fa%CADRE(irangc)%NOZPAR(il)
!
          IF (jtron.EQ.0) THEN
            ihigh=fa%CADRE(irangc)%NOZPAR(il+1)
          ELSE
            ihigh=ilow+4*(icpack+1-jtron)-1
            IF (ihigh.LE.ilow) ihigh=ilow+3
          ENDIF
!
          DO j=ilow,ihigh
            iind=iind+1
            zchaux(iind)=pchamp(j)
          ENDDO
        ENDDO
!
        DO j=1,istria
          pvalco(idecal+inmocc+j)=zchaux(j)
        ENDDO
!
      ELSE
!
        DO j=1,idimnc
          pvalco(idecal+inmocc+j)=REAL (PCHAMP(J), JPDBLD)
        ENDDO
!
      ENDIF
!
    ENDIF
!
  ENDIF
!
  pvalco(3)=transfer(inbits, pvalco(3))
!
  IF (llmlam) THEN
     klongd=idecal+inmocc+istria
  ELSE
     klongd=idecal+inmocc+idimnc
  ENDIF
!
ENDIF
!
IF (ivalc1 == 0 .AND. (jpdblr /= jpdbld)) ivalc1 = -2
pvalco(1)=transfer(ivalc1, pvalco(1))
pvalco(2)=transfer(ivalc2, pvalco(2))
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
llfata=llmoer(krep,krang)
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACINE'
  inumer=jpniil
!
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I4,  &
&         '', CDNOMA='''''',A,'''''', LDCOSP= '',L1,      &
&         '', KLONGD='',I8)')                             &
&     krep, krang, cdnoma, ldcosp, klongd
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr, cdnoma,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FACINE_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE facine_fort
!INTF KREP            OUT                                                              
!INTF KRANG         IN                                                                 
!INTF CDNOMA        IN                                                                 
!INTF PCHAMP        IN    DIMS=*                                                       
!INTF LDCOSP        IN                                                                 
!INTF PVALCO          OUT DIMS=*                                                       
!INTF KLONGD          OUT                                                              
!INTF KB1PAR        INOUT DIMS=FA%JPLB1P                                               
!INTF LDUNDF        IN                                                                 
!INTF PUNDF         IN