fandai.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fandai_fort                                  &
&                     (fa,  krep, krang, kdatef, kdatxf, ldmoda )
USE fa_mod, ONLY : fa_com, jpniil, &
                 & jd_yea, jd_mon, jd_day, & 
                 & jd_hou, jd_min, jd_tun, & 
                 & jd_tho,         jd_ian, &
                 & jd_cu1, jd_cu2,         &
                 & jd_dex,         jd_sem, &
                 & jd_set, jd_ce1, jd_ce2, &
                 & jd_tst, jd_fmt

USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!     Definition d'une (Nouvelle) Date.
!**
!    Arguments : KREP   (Sortie)        ==> Code-reponse du sous-programme;
!                KRANG  (Entree)        ==> Rang de l'unite logique;
!     (Tableau)  KDATEF (Entree/Sortie) ==> Date elle-meme (FA%JPLDAT mots).
!                KDATXF (Entree)        ==> Date etendue
!                LDMODA (Sortie)        ==> Vrai s'il y a modification d'une
!                                           date deja definie.
!*
!       En mode multi-taches, il doit y avoir verrouillage du fichier
!     concerne avant l'appel au sous-programme.
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG
INTEGER (KIND=JPLIKB) KDATEF (fa%jpldat)
INTEGER (KIND=JPLIKB) KDATXF (fa%jpldat)
!
INTEGER (KIND=JPLIKB) IMI123, IMAX69, IMINIM
INTEGER (KIND=JPLIKB) J, ILMOIS, INIMES, INUMER
INTEGER (KIND=JPLIKB) ISECMAX
!
LOGICAL LDMODA
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  CONTROLES DES PARAMETRES D'APPEL.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FANDAI_MT',0,zhook_handle)
clacti=''
ldmoda=.false.
krep=0
!
IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
  krep=-66
  GOTO 1001
ENDIF

IF (kdatxf(jd_dex-fa%JPLDAT) > 0) THEN

!
!         Controle de la Date etendue.
!
  IF (any(kdatxf < 0)) krep=-82

  IF (kdatef(jd_hou) < 0 .AND. kdatef(jd_min) < 0) THEN
    kdatef(jd_hou) = kdatxf(jd_sem-fa%JPLDAT) / 3600
    kdatef(jd_min) = kdatxf(jd_sem-fa%JPLDAT) / 60
  ENDIF
 
!
!         Controle de la coherence de la date et de la date etendue
!
  IF (kdatxf(jd_fmt-fa%JPLDAT) > 0) THEN
    isecmax = 60
  ELSE
    isecmax = 3600
  ENDIF

  IF (abs(kdatef(jd_hou) * 3600 + kdatef(jd_min) * 60 - kdatxf(jd_sem-fa%JPLDAT)) > isecmax) krep=-82

  CALL fandai_cmpsec (kdatef(jd_tun), kdatef(jd_tho), kdatxf(jd_set-fa%JPLDAT))
  CALL fandai_cmpsec (kdatef(jd_tun), kdatef(jd_cu1), kdatxf(jd_ce1-fa%JPLDAT))
  CALL fandai_cmpsec (kdatef(jd_tun), kdatef(jd_cu2), kdatxf(jd_ce2-fa%JPLDAT))

  IF (krep /= 0) GOTO 1001
ENDIF

!
!         Controle de la Date proprement dite.
!
imi123=min(kdatef(jd_yea),kdatef(jd_mon),kdatef(jd_day))
imax69=max(kdatef(jd_tun),kdatef(jd_ian))
iminim=kdatef(jd_yea)
!
DO j=2,fa%JPLDAT
iminim=min(iminim,kdatef(j))
ENDDO
!
IF (iminim.LT.0.OR.imi123.LE.0.OR.kdatef(jd_mon).GT.12.OR.                    &
&   kdatef(jd_day).GT.31.OR.kdatef(jd_hou).GE.24.OR.kdatef(jd_min).GE.60.OR.  &
&   imax69.GE.255.OR.                                                         &
& (kdatef(jd_cu1).LE.kdatef(jd_cu2).AND.(kdatef(jd_cu1)*kdatef(jd_cu2)).NE.0)) THEN
!
!        Erreur de syntaxe.
!
  krep=-82
  GOTO 1001
ELSEIF ((kdatef(jd_mon).GT.7.OR.mod(kdatef(jd_mon),2_jplikb ).EQ.0).AND.  &
&       (kdatef(jd_mon).LE.7.OR.mod(kdatef(jd_mon),2_jplikb ).EQ.1)) THEN
!
!        Controle de coherence (annee,mois,jour).
!
  IF (kdatef(jd_mon).EQ.2) THEN
    ilmois=28+max(0_jplikb ,1-mod(kdatef(jd_yea),4_jplikb ))
  ELSE
    ilmois=30
  ENDIF
!
  IF (kdatef(jd_day).GT.ilmois) THEN
    krep=-82
    GOTO 1001
  ENDIF
!
ENDIF


IF (kdatxf(jd_dex-fa%JPLDAT) == 0) THEN
  
!
!        Calcul de la date etendue si elle n'est pas definie
!
  kdatxf(jd_dex-fa%JPLDAT) = 1
  kdatxf(jd_sem-fa%JPLDAT) = kdatef(jd_hou) * 3600 + kdatef(jd_min) * 60

  CALL fandai_setsec (kdatef(jd_tun), kdatef(jd_tho), kdatxf(jd_set-fa%JPLDAT))
  CALL fandai_setsec (kdatef(jd_tun), kdatef(jd_cu1), kdatxf(jd_ce1-fa%JPLDAT))
  CALL fandai_setsec (kdatef(jd_tun), kdatef(jd_cu2), kdatxf(jd_ce2-fa%JPLDAT))
  kdatxf(jd_tst-fa%JPLDAT) = 1800

ENDIF

!**
!     2.  -  SI DATE DEJA DEFINIE, COMPARAISON ANCIENNE/NOUVELLE.
!-----------------------------------------------------------------------
!
IF (.NOT. fa%FICHIER(krang)%LCREAF) THEN
!
  DO j=1,fa%JPLDAT
!
  IF (fa%FICHIER(krang)%MADATE(j).NE.kdatef(j)) THEN
    ldmoda=.true.
    GOTO 300
  ENDIF
!
  ENDDO
!
  DO j=1,fa%JPLDAT
!
  IF (fa%FICHIER(krang)%MADATX(j).NE.kdatxf(j)) THEN
    ldmoda=.true.
    GOTO 300
  ENDIF
!
  ENDDO
!
!         Si on arrive ici, il y a redefinition a l'identique.
!
  GOTO 1001
ENDIF
!**
!     3.  -  SI NECESSAIRE, MISE A JOUR DU TABLEAU "FA%MADATE".
!-----------------------------------------------------------------------
!
300 CONTINUE
!
fa%FICHIER(krang)%MADATE (:) = kdatef(:)
fa%FICHIER(krang)%MADATX (:) = kdatxf(:)
!**
!    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='FANDAI'
  inumer=jpniil
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I4,    &
&       '', KDATEF(1:5)='',I5,2(''/'',I2),I3,'':'',I2.2,    &
&       '', KDATEF(7:8)='',I6,''-'',I6,'', KDATXF='',11I6,  &
&       '', LDMODA= '',L1)') &
&     krep,krang,(kdatef(j),j=1,5),(kdatef(j),j=7,8),kdatxf,&
&     ldmoda
  CALL faipar_fort                                      &
&               (fa, inumer,inimes,krep,.false.,clmess, &
&                clnspr,clacti, .false.)
ENDIF
!
IF (lhook) CALL dr_hook('FANDAI_MT',1,zhook_handle)

CONTAINS

SUBROUTINE fandai_setsec (KDATEF6, KDATEFX, KSECS)

INTEGER (KIND=JPLIKB), INTENT (IN)    :: KDATEF6
INTEGER (KIND=JPLIKB), INTENT (IN)    :: KDATEFX
INTEGER (KIND=JPLIKB), INTENT (INOUT) :: KSECS

SELECT CASE (kdatef6)
  CASE (1)
    ksecs = kdatefx * 3600
  CASE (2)
    ksecs = kdatefx * 3600 * 24
  CASE DEFAULT
    ksecs = -1
END SELECT

END SUBROUTINE fandai_setsec

SUBROUTINE fandai_cmpsec (KDATEF6, KDATEFX, KSECS)

INTEGER (KIND=JPLIKB), INTENT (INOUT) :: KDATEF6
INTEGER (KIND=JPLIKB), INTENT (INOUT) :: KDATEFX
INTEGER (KIND=JPLIKB), INTENT (IN)    :: KSECS

IF (kdatef6 < 0) THEN
  IF (ksecs < 65000) THEN
    kdatef6 = 1
  ELSE
    kdatef6 = 2
  ENDIF
ENDIF

IF (kdatefx < 0) THEN

  SELECT CASE (kdatef6)
    CASE (1)
      kdatefx = nint(REAL (KSECS, JPDBLR) / 3600._JPDBLR)
    CASE (2)
      kdatefx = nint(REAL (KSECS, JPDBLR) / 3600._JPDBLR) / 24
    CASE DEFAULT
      krep=-82
  END SELECT

ENDIF

SELECT CASE (kdatef6)
  CASE (1)
    IF (abs(kdatefx * 3600 - ksecs) > 3600) THEN
      krep=-82
    ENDIF
  CASE (2)
    IF (abs(kdatefx * 3600 * 24 - ksecs) > 3600 * 24) THEN
      krep=-82
    ENDIF
  CASE DEFAULT
    krep=-82
END SELECT

END SUBROUTINE fandai_cmpsec

#include "facom2.llmoer.h"

END SUBROUTINE fandai_fort