facsim.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE facsim_fort                                    &
&                     (fa,  krep, krang, pchame, pchams,  &
&                      kpulas, kstron)
USE fa_mod, ONLY : fa_com, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!     traitement des champs en coefficients spectraux, preparatoire
!     au codage GRIB.
!              ( Coefficients Spectraux, Integration Methodique ! )
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KRANG  (Entree) ==> Rang de l'unite logique;
!    ( Tableau ) PCHAME (Entree) ==> Champ en coef. spectraux en entree;
!    ( Tableau ) PCHAMS (Sortie) ==> Champ en sortie, partie a coder;
!                KPULAS (Sortie) ==> Puissance de laplacien utilisee.
!                KSTRON (Entree) ==> Niveau de sous-troncature non
!                                    compactee.
!*
!       En mode multi-taches, il doit y avoir verrouillage du fichier
!     concerne avant l'appel au sous-programme.
!
!     Modifications
!     -------------
!
!  Juillet 1998, J. Clochard, SCEM/TTI/DAO:
!
!    -Reinitialisation de tableaux utilises pour le calcul iteratif
!     au changement de sens de balayage.
!    -Plus de "IF" pour le calcul d'extrema dans le cas ALADIN.
!    -Diagnostic plus precis en mode "mise au point".
!
!  Octobre 1998, J. Clochard, SCEM/TTI/DAO:
!
!    -Ajout de l'argument d'appel KSTRON pour compatibilite avec
!     evaluation dynamique (eventuelle) de la sous-troncature en
!     fonction de la troncature et du nombre de bits par valeur
!     compactee.
!
!  Avril   2004, D. Paradis,  DSI/DEV:
!
!    -Initialisations des tableaux XLAPxDx et FLAP1Dx faites
!     en debut de routine par appel a FAIXLA et FAIFLA.
!
!  April  2009, F. Vana and NEC:
!
!    - OpenMP directives
!
!  March 2010: J. Masek - fix of precomputed optimal Laplacian power
!              F. Vana  - simplification of IFC_SMAX,IFC_SMIN for
!                              better performance
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG, KPULAS, KSTRON
!
REAL (KIND=JPDBLR) PCHAME (*), PCHAMS (*)
!
INTEGER (KIND=JPLIKB) IDIMNC, IRANGC, ITRONC, IPUFLA
INTEGER (KIND=JPLIKB) JN, J
INTEGER (KIND=JPLIKB) IMLIM, IOFF, IM, IMOD, INDLAP
INTEGER (KIND=JPLIKB) INDZ, ILONG, IDECAL, IMINI
INTEGER (KIND=JPLIKB) IMAXI, ILCHAM, INBITS, IMTRONC
INTEGER (KIND=JPLIKB) IMODPL, JIND
INTEGER (KIND=JPLIKB) IMEILL, JSENS, INDICE, IPUISS
INTEGER (KIND=JPLIKB) IPOSEX, JMODPL
INTEGER (KIND=JPLIKB) IPLUS, IMOINS, IPUISX, IPUIS2
INTEGER (KIND=JPLIKB) IRAPOR, IPUISR, INIMES
INTEGER (KIND=JPLIKB) INUMER, IDEB, IFIN, IXLOPA
INTEGER (KIND=JPLIKB) IPULAS (0:1)
!
REAL (KIND=JPDBLR) ZMIN, ZMAX, ZERRXI, ZERRXF, ZBIGVA
REAL (KIND=JPDBLR) ZMINI (fa%jpxtro,0:2),ZMAXI (fa%jpxtro,0:2)
REAL (KIND=JPDBLR) Z(4*fa%jpxtro*fa%jpxtro,2)
REAL (KIND=JPDBLR) ZECART (2,0:1)
!
LOGICAL LLARPE,LLMLAM
!
INTEGER (KIND=JPLIKB), EXTERNAL :: ISMIN_164 , ISMAX_164 
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FACSIM_MT',0,zhook_handle)
clacti=''
idimnc=0
zbigva=huge(zbigva)
!
IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
  krep=-66
  GOTO 1001
ENDIF
!
! Si ce n'est pas encore fait, initialisation des tableaux XLAP... et FA%FLAP1D.
!
IF (fa%LIXLAP) THEN
  CALL faixla_fort           &
&                 (fa)
  fa%LIXLAP = .false.
ENDIF
IF (fa%FICHIER(krang)%LIFLAP) THEN
  CALL faifla_fort           &
&                (fa, krang)
  fa%FICHIER(krang)%LIFLAP = .false.
ENDIF
!
irangc=fa%FICHIER(krang)%NUCADR
itronc=fa%CADRE(irangc)%MTRONC
ixlopa=fa%CADRE(irangc)%NXLOPA
llmlam=fa%CADRE(irangc)%LIMLAM
!
IF (llmlam) imtronc=fa%CADRE(irangc)%NOZPAR(2)
IF (itronc.LE.kstron) THEN
  krep=-88
  GOTO 1001
ELSEIF (llmlam.AND.imtronc.LE.kstron) THEN
  krep=-88
  GOTO 1001
ELSEIF (llmlam.AND.(imtronc.GT.3*itronc.OR. &
&    itronc.GT.3*imtronc)) THEN
! Il s'agit d'un garde-fou, modifiable (ne pas oublier FARCIS et FAPULA)
  krep=-114
  GOTO 1001
ELSE       
  krep=0
ENDIF
!
ipufla=fa%FICHIER(krang)%NPUFLA
imodpl=fa%FICHIER(krang)%NMFDPL
!
IF (llmlam) THEN
   ilcham=fa%CADRE(irangc)%NSFLAM
   idimnc=4*(1+itronc+imtronc+(kstron*(kstron-1))/2)
!DP      IDIMNC=FA%NOZPAR(5,IRANGC)+4*KSTRON-1
ELSE
   ilcham=(1+itronc)**2
   idimnc=(1+kstron)**2
ENDIF
!**
!     2.  -  DETERMINATION DE LA "MEILLEURE" PUISSANCE DE LAPLACIEN
!            POUR LA PARTIE DU CHAMP QUI SERA COMPACTEE EN "GRIB".
!-----------------------------------------------------------------------
!
IF (imodpl.EQ.0) THEN
!
!           On elimine le cas ou aucune modulation de la puissance
!         de laplacien n'est possible.
!
  kpulas=ipufla
  GOTO 300
ENDIF
!*
!     2.1 -  AMORCAGE DU PROCESSUS ITERATIF: CALCUL DES EXTREMA DU CHAMP
!            MULTIPLIE PAR LA PUISSANCE DE LAPLACIEN NOMINALE DU FICHIER
!            ( le traitement est decoupe nombre d'onde "n" par "n" )
!-----------------------------------------------------------------------
!
!       Calcul des extrema du champ d'entree (partie a compacter),
!     pour chaque nombre d'onde "n".
!
IF (llmlam) THEN
  zmin=zbigva
  zmax=-zbigva
!$OMP PARALLEL DO IF(FA%LOPENMP)                                &
!$OMP&PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,IMOD,INDLAP,INDZ) &
!$OMP&REDUCTION(MAX:ZMAX) REDUCTION(MIN:ZMIN)
  DO jn=1,itronc
   imlim=kstron-jn
   ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
&          fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
   ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
  DO jind=ideb,ifin
    ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
    im=ioff/4
    imod=mod(ioff,4_jplikb )
!
    indlap=((jn-1)*fa%JPXTRO)+im
    indz=imod*fa%JPXTRO*fa%JPXTRO+indlap
    z(indz,1)=pchame(jind)*fa%FICHIER(krang)%FLAP1DA(indlap)
    zmax=max(zmax,z(indz,1))
    zmin=min(zmin,z(indz,1))
!
  ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
  DO jn=kstron+1,itronc
  ilong=2*jn+1
  idecal=jn**2
  imaxi=ismax_164(ilong, pchame(idecal+1))
  zmaxi(jn,0)=pchame(idecal+imaxi)
  imini=ismin_164(ilong, pchame(idecal+1))
  zmini(jn,0)=pchame(idecal+imini)
  ENDDO
!
!
!
  DO jn=kstron+1,itronc
  zmaxi(jn,1)=zmaxi(jn,0)*fa%FICHIER(krang)%FLAP1D(jn)
  zmini(jn,1)=zmini(jn,0)*fa%FICHIER(krang)%FLAP1D(jn)
  ENDDO
!
!
  imaxi=kstron+ismax_164  &
&                (itronc-kstron,zmaxi(kstron+1,1))
  imini=kstron+ismin_164  &
&                (itronc-kstron,zmini(kstron+1,1))
  zmin=zmini(imini,1)
  zmax=zmaxi(imaxi,1)
ENDIF
!
inbits=fa%FICHIER(krang)%NBFCSP
llarpe=fa%FICHIER(krang)%NFGRIB.EQ.2
!
IF (zmax.LE.zmin) THEN
!
!           On elimine le cas trivial du champ constant,
!         eventuellement apres transformation...
!
  kpulas=ipufla
  GOTO 300
ENDIF
!
!        Calcul de l'erreur de compactage initiale.
!
CALL faxion_fort                                                              &
&               (fa, pchame,ipufla,idimnc,ilcham,zmin,                        &
&                zmax,inbits,llarpe,zerrxi,llmlam,fa%CADRE(irangc)%NOZPAR(1), &
&                kstron,itronc,ixlopa)
imeill=0
zecart(2,imeill)=zerrxi
!*
!     2.3 -  BOUCLE SUR LES DEGRES DE MODULATION POSSIBLES,
!            PAR INCREMENTS DE PUISSANCE VALANT +1 (ESSAYE EN PREMIER)
!            PUIS (-1).
!-----------------------------------------------------------------------
!
DO 239 jsens=1,-1,-2
indice=(1-jsens)/2
ipuiss=ipufla
zecart(1,indice)=zerrxi
iposex=2
!
IF (jsens.EQ.-1) THEN
!
!       Compte-tenu du caractere "incremental" du calcul des extrema
!       pour des puissances successives, on doit reinitialiser lors du
!       changement de sens de balayage ZMAXI et ZMINI pour le cas ARPEGE
!       et Z pour le cas ALADIN.
!
  IF (llmlam) THEN
!
    zmin=zbigva
    zmax=-zbigva
!$OMP PARALLEL DO IF(FA%LOPENMP)                                 &
!$OMP&PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,IMOD,INDLAP,INDZ)
    DO jn=1,itronc
    imlim=kstron-jn
    ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
&           fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
    ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
    DO jind=ideb,ifin
    ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
    im=ioff/4
    imod=mod(ioff,4_jplikb )
!
       indlap=((jn-1)*fa%JPXTRO)+im
       indz=imod*fa%JPXTRO*fa%JPXTRO+indlap
       z(indz,1)=pchame(jind)*fa%FICHIER(krang)%FLAP1DA(indlap)
!
    ENDDO
    ENDDO
!$OMP END PARALLEL DO
!
  ELSE
!
    DO jn=kstron+1,itronc
    zmaxi(jn,1)=zmaxi(jn,0)*fa%FICHIER(krang)%FLAP1D(jn)
    zmini(jn,1)=zmini(jn,0)*fa%FICHIER(krang)%FLAP1D(jn)
    ENDDO
!
  ENDIF
!
ENDIF
!
DO jmodpl=1,imodpl
ipuiss=ipuiss+jsens
!
IF (llmlam) THEN
  zmin=zbigva
  zmax=-zbigva
!$OMP PARALLEL DO IF(FA%LOPENMP)                                 &
!$OMP&PRIVATE(JN,IMLIM,IDEB,IFIN,JIND,IOFF,IM,IMOD,INDLAP,INDZ)  &
!$OMP&REDUCTION(MAX:ZMAX) REDUCTION(MIN:ZMIN)
  DO jn=1,itronc
  imlim=kstron-jn
  ideb=max(fa%CADRE(irangc)%NOZPAR(2*jn+3)+4*(1+imlim), &
&         fa%CADRE(irangc)%NOZPAR(2*jn+3)+4)
  ifin=fa%CADRE(irangc)%NOZPAR(2*jn+4)
!ocl novrec
  DO jind=ideb,ifin
  ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
  im=ioff/4
  imod=mod(ioff,4_jplikb )
!
     indlap=((jn-1)*fa%JPXTRO)+im
     indz=imod*fa%JPXTRO*fa%JPXTRO+((jn-1)*fa%JPXTRO)+im
     z(indz,iposex)=z(indz,3-iposex)* &
&     fa%XLAP1DA(indlap,indice)
     zmax=max(zmax,z(indz,iposex))
     zmin=min(zmin,z(indz,iposex))
!
  ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE 
  DO jn=kstron+1,itronc
  zmaxi(jn,iposex)=zmaxi(jn,3-iposex)*fa%XLAP1D(jn,indice)
  zmini(jn,iposex)=zmini(jn,3-iposex)*fa%XLAP1D(jn,indice)
  ENDDO
!
  imaxi=kstron+ismax_164  &
&               (itronc-kstron,zmaxi(kstron+1,iposex))
  imini=kstron+ismin_164  &
&               (itronc-kstron,zmini(kstron+1,iposex))
  zmin=zmini(imini,iposex)
  zmax=zmaxi(imaxi,iposex)
ENDIF
!
IF (zmax.LE.zmin) THEN
!
!           On elimine le cas du champ constant...
!
  kpulas=ipuiss
  GOTO 240
ENDIF
!
!        Calcul de la nouvelle erreur de compactage.
!
CALL faxion_fort                                                      &
&               (fa, pchame,ipuiss,idimnc,ilcham,zmin,zmax,inbits,    &
&                llarpe,zecart(iposex,indice),llmlam,                 &
&                fa%CADRE(irangc)%NOZPAR(1),kstron,itronc,ixlopa)
!
IF (zecart(iposex,indice).GE.zecart(3-iposex,indice)) THEN
!
!        Ecart pas meilleur que celui calcule precedemment, on s'arrete.
!
  ipulas(indice)=ipuiss-jsens
  GOTO 239
ENDIF
!
iposex=3-iposex
ENDDO
!
!        On a epuise les degres de modulation possibles... on plafonne.
!                    (pour un sens de balayage)
!
ipulas(indice)=ipuiss
239 CONTINUE
!
!        Choix du meilleur resultat obtenu dans les 2 sens de balayage.
!
iplus=1+mod(ipulas(0)-ipufla,2_jplikb )
imoins=1+mod(ipufla-ipulas(1),2_jplikb )
!
IF (zecart(iplus,0).LE.zecart(imoins,1)) THEN
  imeill=0
ELSE
  imeill=1
ENDIF
!
kpulas=ipulas(imeill)
!
240 CONTINUE
!*
!     2.4 -  DIAGNOSTICS EVENTUELS, EN MODE MISE AU POINT SEULEMENT.
!-----------------------------------------------------------------------
!
IF (fa%LFAMOP) THEN
  zerrxf=min(zecart(1,imeill),zecart(2,imeill))
  WRITE (unit=fa%NULOUT,fmt=*)                               &
&         'FACSIM - Erreur Initiale (P=',ipufla,') ',zerrxi, &
&         ', Finale (P=',kpulas,') ', zerrxf
ENDIF
!**
!     3.  -  TRANSFORMATION DE LA PARTIE A COMPACTER DU CHAMP.
!-----------------------------------------------------------------------
!
300 CONTINUE
!
!        On fait des multiplications plutot que des divisions,
!     et on essaie d'eviter l'exponentiation.
!
IF (kpulas.EQ.0) THEN
!
  IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND) IF(FA%LOPENMP)
    DO jn=0,itronc
    DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3),fa%CADRE(irangc)%NOZPAR(2*jn+4)
    pchams(jind)=pchame(jind)
    ENDDO
    ENDDO
!$OMP END PARALLEL DO
  ELSE
    DO j=idimnc+1,ilcham
    pchams(j)=pchame(j)
    ENDDO
  ENDIF
!
ELSE
  ipuisx=abs(kpulas)
!
  IF (kpulas.GT.0) THEN
    indice=0
  ELSE
    indice=1
  ENDIF
!
  IF (ipuisx.LE.fa%JPUILA) THEN
!
    IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP) IF(FA%LOPENMP)
      DO jn=1,itronc
      DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3)+4, &
&                   fa%CADRE(irangc)%NOZPAR(2*jn+4)
      ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
      im=ioff/4
      indlap=((jn-1)*fa%JPXTRO)+im
      pchams(jind)=pchame(jind)*fa%XLAP2DA(indlap,ipuisx,indice)
      ENDDO
      ENDDO
!$OMP END PARALLEL DO
    ELSE
      DO j=idimnc+1,ilcham
      pchams(j)=pchame(j)*fa%XLAP2D(j,ipuisx,indice)
      ENDDO
    ENDIF
!
  ELSEIF (ipuisx.LE.2*fa%JPUILA) THEN
    ipuis2=ipuisx/2
!
    IF (ipuisx.EQ.2*ipuis2) THEN
!
      IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP) IF(FA%LOPENMP)
        DO jn=1,itronc
        DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3)+4, &
&                     fa%CADRE(irangc)%NOZPAR(2*jn+4)
        ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
        im=ioff/4
        indlap=((jn-1)*fa%JPXTRO)+im
        pchams(jind)=pchame(jind)*                       &
&                     fa%XLAP2DA(indlap,ipuis2,indice)**2
        ENDDO
        ENDDO
!$OMP END PARALLEL DO
      ELSE
        DO j=idimnc+1,ilcham
        pchams(j)=pchame(j)*fa%XLAP2D(j,ipuis2,indice)**2
        ENDDO
      ENDIF
!
    ELSE
!
      IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP) IF(FA%LOPENMP)
        DO jn=1,itronc
        DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3)+4, &
&                     fa%CADRE(irangc)%NOZPAR(2*jn+4)     
        ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
        im=ioff/4
        indlap=((jn-1)*fa%JPXTRO)+im
        pchams(jind)=pchame(jind)*                          &
&                fa%XLAP2DA(indlap,fa%JPUILA,indice)         &
&                *fa%XLAP2DA(indlap,ipuisx-fa%JPUILA,indice)
        ENDDO
        ENDDO
!$OMP END PARALLEL DO

      ELSE
        DO j=idimnc+1,ilcham
        pchams(j)=pchame(j)*fa%XLAP2D(j,fa%JPUILA,indice) &
&                *fa%XLAP2D(j,ipuisx-fa%JPUILA,indice)
        ENDDO
      ENDIF
    ENDIF
!
  ELSE
    irapor=1+(ipuisx-1)/fa%JPUILA
    ipuisr=ipuisx/irapor
!
    IF (ipuisx.EQ.irapor*ipuisr) THEN
! 
      IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP) IF(FA%LOPENMP)
        DO jn=1,itronc
        DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3)+4, &
&                     fa%CADRE(irangc)%NOZPAR(2*jn+4)
        ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
        im=ioff/4
        indlap=((jn-1)*fa%JPXTRO)+im
        pchams(jind)=pchame(jind)*                   &
&            fa%XLAP2DA(indlap,ipuisr,indice)**irapor
        ENDDO
        ENDDO
!$OMP END PARALLEL DO
      ELSE
        DO j=idimnc+1,ilcham
        pchams(j)=pchame(j)*fa%XLAP2D(j,ipuisr,indice)**irapor
        ENDDO
      ENDIF
! 
    ELSE
!
      IF (llmlam) THEN
!$OMP PARALLEL DO PRIVATE(JN,JIND,IOFF,IM,INDLAP) IF(FA%LOPENMP)
        DO jn=1,itronc
        DO jind=fa%CADRE(irangc)%NOZPAR(2*jn+3)+4, &
&                     fa%CADRE(irangc)%NOZPAR(2*jn+4)
        ioff=jind-fa%CADRE(irangc)%NOZPAR(2*jn+3)
        im=ioff/4
        indlap=((jn-1)*fa%JPXTRO)+im
        pchams(jind)=pchame(jind)*                              &
&          fa%XLAP2DA(indlap,fa%JPUILA,indice)**(irapor-1)*      &
&          fa%XLAP2DA(indlap,ipuisx-fa%JPUILA*(irapor-1),indice)
        ENDDO
        ENDDO
!$OMP END PARALLEL DO
      ELSE
        DO j=idimnc+1,ilcham
        pchams(j)=pchame(j)*                                     &
&                  fa%XLAP2D(j,fa%JPUILA,indice)**(irapor-1)      &
&                *fa%XLAP2D(j,ipuisx-fa%JPUILA*(irapor-1),indice)
        ENDDO
      ENDIF
!
    ENDIF
!
  ENDIF
!
ENDIF
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE EVENTUELLE,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE

llfata=llmoer(krep,krang)
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACSIM'
  inumer=jpniil
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I4,       &
&         '', PCHAME(1)='',G12.5,'', PCHAMS('',I3,'')='',G12.5, &
&         '', KPULAS='',I3)')                                   &
&     krep,krang,pchame(1),idimnc+1,pchams(idimnc+1),kpulas
  CALL faipar_fort                                      &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&               clnspr,clacti,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FACSIM_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE


!INTF KREP            OUT                               
!INTF KRANG         IN                                  
!INTF PCHAME        IN    DIMS=*                        
!INTF PCHAMS          OUT DIMS=*                        
!INTF KPULAS          OUT                               
!INTF KSTRON        IN