! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX

!========================================================================
! Laboratoire de Physique des Plasmas
! Date/Time Utilities Library  used in Roproc and RPC project
! Initially written in Fortran 77 for first Roproc version
! Patrick ROBERT, CETP, ~ years 2000
! Converted and updated in Fortran 90 for RPC project ~2009
! Retrieved from RPC Patrick ROBERT, LPP, 2011 March 07
!========================================================================

      subroutine addsec_datiso(datiso1,sec,datiso2)
!
!     ------------------------------------------------------------------
! *   Object : additionne a la date ISO un temps en sec.
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2002
!     ------------------------------------------------------------------
!
      character*(*) datiso1,datiso2
!
      call decode_datiso(datiso1,iyear,imon,iday,ih,im,is,ims,imc)
      call cojd50(iyear,imon,iday,jd50)
      call codecsec(0,ih,im,is,ims,imc,sec1)

      sec2=sec1 +sec

      call codecsecinv(sec2,nbday,ih,im,is,ims,imc)
      call cdatjd50(jd50+nbday,iyear,imon,iday)

      call encode_datiso(iyear,imon,iday,ih,im,is,ims,imc,datiso2)

      return
      end
!
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine addsecdbl_datiso(datiso1,secdbl,datiso2)
!
!     ------------------------------------------------------------------
! *   Object : additionne a la date ISO un temps en sec. double
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2002
!     History :
!       LMI - 20 May 2009 : si datiso1 eet plus courte que datiso2
!                           on renvoie datiso2 avec la même précision.
!     ------------------------------------------------------------------
!
      character*(*) datiso1,datiso2
      double precision secdbl,secdbl1,secdbl2
      integer posZ
      integer idoy,ily

      call decode_datiso(datiso1,iyear,imon,iday,ih,im,is,ims,imc)
      call cojd50(iyear,imon,iday,jd50)
      call codecsecdbl(0,ih,im,is,ims,imc,secdbl1)

      secdbl2=secdbl1 +secdbl

      call codecsecdblinv(secdbl2,nbday,ih,im,is,ims,imc)
      call cdatjd50(jd50+nbday,iyear,imon,iday)

      posz=INDEX(datiso1,'Z')
      if (posZ.eq.24) then
         idoy=0
         if (imc.ge.500) then
            if (imon.gt.1) then
               idoy=idoy+31
            endif
            if (imon.gt.2) then
               call coleapyear(iyear,ily)
               if (ily.eq.0) then
                  idoy=idoy+28
               else
                  idoy=idoy+29
               endif
            endif
            if (imon.gt.3) then
               idoy=idoy+31
            endif
            if (imon.gt.4) then
               idoy=idoy+30
            endif
            if (imon.gt.5) then
               idoy=idoy+31
            endif
            if (imon.gt.6) then
               idoy=idoy+30
            endif
            if (imon.gt.7) then
               idoy=idoy+31
            endif
            if (imon.gt.8) then
               idoy=idoy+31
            endif
            if (imon.gt.9) then
               idoy=idoy+30
            endif
            if (imon.gt.10) then
               idoy=idoy+31
            endif
            if (imon.gt.11) then
               idoy=idoy+30
            endif
            idoy=idoy+iday
            ims=ims+1
            if(ims.ge.1000) then
               ims=ims-1000
               is=is+1
               if(is.ge.60) then
                  is=is-60
                  im=im+1
                  if(im.ge.60) then
                     im=im-60
                     ih=ih+1
                     if(ih.ge.24) then
                        ih=ih-24
                        idoy=idoy+1
                        call cdatdoty(idoy,iyear,imon,iday)
                     endif
                  endif
               endif
            endif
         endif
         imc=-1
      endif

      call encode_datiso(iyear,imon,iday,ih,im,is,ims,imc,datiso2)

      return
      end
!
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine cdatdoty(idoy,iyear,imonth,iday)

! ----------------------------------------------------------------------
!
! *   Class  : calendar modules of Rocotlib Software
! *   Object : compute_date_from_day_of_year and for a given year
! *   Author : P. Robert, CRPE, 1992
! *   Comment: none
!
! *   input  : iyear,idoy (idoy=1 for january 1)
! *   output : imonth,iday
!
! ----------------------------------------------------------------------
!

      dimension month(12)
      data month/31,28,31,30,31,30,31,31,30,31,30,31/

      call coleapyear(iyear,ily)

      if(idoy.gt.365.and.ily.eq.0) then
                                    print*,iyear,' is not a leap year'
                                    print*,'no more 365 day'
      write(*,*) 'CDATDOTY : *** ABORTED ! THIS YEAR HAS 365 DAYS ***'
      stop 'lib_time.o/cdatdoty             : *** ERROR !! Program aborted !'
                                    endif

      if(idoy.lt.1) then
                    print*,'day of the year must be grather than 0'
      write(*,*) 'CDATDOTY : *** ABORTED ! DAY OF THE YEAR MUST BE >0 ***'
      stop 'lib_time.o/cdatdoty             : *** ERROR !! Program aborted !'
                     endif

      if(ily.eq.1) then
                   month(2)=29
                   else
                   month(2)=28
                   endif

      m=0

      do 10 im=1,12
      mp=m
      m=m+month(im)
      if(idoy.le.m) go to 20
   10 continue
   20 continue

      imonth=im
      iday=idoy-mp

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine cdatjd50(jd50,iyear,imonth,iday)
!
! ----------------------------------------------------------------------
!
! *   Class  : calendar modules of Rocotlib Software
! *   Object : compute_date_from_julian_day_1950 with jd50=0 for jan. 1
! *   Author : P. Robert, CRPE, 1992
! *   Comment: compute date as year, month, day from julian day 1950
!
! *   input  : jd50  julian day 1950 (0= 1/1/1950)
! *   output : iyear,imonth,iday
!
! ----------------------------------------------------------------------
!

      jd1= -1

      do 10 iy=1950,3000
      call coleapyear(iy,ily)
      jdp=jd1
      if(ily.eq.1) then
                   jd1=jd1+366
                   else
                   jd1=jd1+365
                   endif
      if(jd1.ge.jd50) then
                       iyear=iy
                       go to 20
                       endif

   10 continue
      print*, 'julian day correspond to year grather than 3000'
      write(*,*) 'CDATJD50 : *** ABORTED ! JULIAN DAY > YEAR 3000 ***'
      stop 'lib_time.o/cdatjd50             : *** ERROR !! Program aborted !'

   20 continue
      jd=jd50-jdp
      call cdatdoty(jd,iy,imonth,iday)

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine check_datiso(datiso)

      character*(*) datiso
      character*27 err

      err='good'

      call decode_datiso(datiso,iyear,imon,iday,ih,im,is,ims,imc)

      if(iyear.gt.5000) err='XXXX'
      if(imon .gt.12)   err='    -XX'
      if(iday .gt.31)   err='    -  -XX'
      if(ih   .gt.24)   err='    -  -  TXX'
      if(im   .gt.60)   err='    -  -  T  :XX'
      if(is   .gt.60)   err='    -  -  T  :  :XX'
      if(ims  .gt.999)  err='    -  -  T  :  :  .XXX'
      if(imc  .gt.999)  err='    -  -  T  :  :  .   XXX'

      if(err(1:4) /= 'good' ) then
         write(*,'(a)') '***************************'
         write(*,'(a)') datiso
         write(*,'(a)') err
         write(*,'(a)') '***************************'
         write(*,*) 'check_datiso    *** ABORTED ! iso date not correct ***'
         stop 'lib_time.o/check_datiso          : *** ERROR !! Program aborted !'
      endif

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine clean_datiso(datiso,datpat)
!
!     ------------------------------------------------------------------
! *   Object : converti la date iso  ex: '2000-09-13 12:09:56.868055'
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2002 Sep.
!     ------------------------------------------------------------------
!
      character*(*) datiso,datpat
!
!                    *********************
!
      datpat=datiso

      nt=INDEX(datiso,'T')
      nz=INDEX(datiso,'Z')

      if(nt.eq.0) then
                  print*, 'clean_datiso: pas de champ "T" dans datiso'
                  return
                  endif

      if(nz.eq.0) then
                  print*, 'clean_datiso: pas de champ "Z" dans datiso'
                  return
                  endif

      datpat(nt:nt)=' '
      datpat(nz:nz)=' '

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine codecsec(nbday,ih,im,is,ims,imc, decsec)

      real (kind=8) :: secdbl
!
!     ------------------------------------------------------------------
! *   Object : calcule la seconde decimale  d'un temps
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001,Jan.
!     ------------------------------------------------------------------
!
      secdbl= dble(nbday*24*3600 +ih*3600 + im*60 + is) &
                                                  + dble(ims)/1000.d0 &
                                                  + dble(imc)/1000000.d0

      decsec=real(secdbl)

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine codecsecdbl(nbday,ih,im,is,ims,imc, secdbl)
!
      double precision secdbl
!
!     ------------------------------------------------------------------
! *   Object : calcule la seconde decimale dble  d'un temps
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001 Jan.
!     ------------------------------------------------------------------
!
      secdbl= dble(nbday*24*3600 +ih*3600 + im*60 + is) &
                                                  + dble(ims)/1000.d0 &
                                                  + dble(imc)/1000000.d0

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine codecsecinv(decsec,nbday,ih,im,is,ims,imc)

      double precision secdbl,toto
!
!     ------------------------------------------------------------------
! *   Object : convertie la seconde decimale dble en nbday,ih,im,is,ims
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001 Jan.
!              09 Apr 2010 - LMI - gfortran compliance
!     ------------------------------------------------------------------
!
      nbday = 0

      do while (decsec.lt.0.)
         decsec=decsec+24.*3600.
         nbday=nbday-1
      enddo

      secdbl=dble(decsec)

      if (nbday .eq. 0) then
         nbday=int(secdbl/dble(24*3600))
         toto=secdbl-dble(nbday*24*3600)
      else
         toto=secdbl
      endif

      ih= int(toto/3600.d0)
      toto=toto-dble(ih*3600)
      if(ih.lt.0.or.ih.gt.24) then
                              print*,'***/ NBDAY,IH=',nbday,ih
      write(*,*) 'CODECSECINV    *** ABORTED ! ERROR ON IH                ***'
      stop 'lib_time.o/codecsecinv           : *** ERROR !! Program aborted !'
                              endif

      im= int(toto/60.d0)
      toto=toto-dble(im*60)
      if(im.lt.0.or.im.gt.59) then
                              print*,'***/ NBDAY,IH,IM=',nbday,ih,im
      write(*,*) 'CODECSECINV    *** ABORTED ! ERROR ON IM                ***'
      stop 'lib_time.o/codecsecinv           : *** ERROR !! Program aborted !'
                              endif

      is= int(toto)
      toto=toto-dble(is)
      if(is.lt.0.or.is.gt.59) then
                           print*,'***/ NBDAY,IH,IM,IS=',nbday,ih,im,is
      write(*,*) 'CODECSECINV    *** ABORTED ! ERROR ON IS                ***'
      stop 'lib_time.o/codecsecinv           : *** ERROR !! Program aborted !'
                              endif
!
      ims= int(toto*1000.d0)
      toto=toto-dble(float(ims))/1000.d0
      if(ims.lt.0.or.ims.gt.999) then
                                print*,'***/ IH,IM,IS,IMS=',ih,im,is,ims
      write(*,*) 'CODECSECINV    *** ABORTED ! ERROR ON IMS               ***'
      stop 'lib_time.o/codecsecinv           : *** ERROR !! Program aborted !'
                                 endif
!
      imc= int(toto*1000000.d0)
      if(imc.lt.0.or.imc.gt.999) then
                                 print*,'***/ IMC=',imc
      write(*,*) 'CODECSECINV    *** ABORTED ! ERROR ON IMC               ***'
      stop 'lib_time.o/codecsecinv           : *** ERROR !! Program aborted !'
                                 endif
!
      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine codecsecdblinv(secdbl,nbday,ih,im,is,ims,imc)

      real(kind=8)  :: secdbl,toto

!     ------------------------------------------------------------------
! *   Object : convertie la seconde decimale dble en nbday,ih,im,is,ims
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001 Jan.
!     ------------------------------------------------------------------

      nbday = 0

      do while (secdbl<0.D0)
         secdbl=secdbl+24.D0*3600.D0
         nbday=nbday-1
      enddo

      if (nbday == 0) then
         nbday=int(secdbl/dble(24*3600))
         toto=secdbl-dble(nbday*24*3600)
      else
         toto=secdbl
      endif

      ih= int(toto/3600.d0)
      toto=toto-dble(ih*3600)
      if(ih.lt.0.or.ih.gt.24) then
      print*,'***/ NBDAY,IH=',nbday,ih
      write(*,*) 'CODECSECDBLINV *** ABORTED ! ERROR ON IH                ***'
      stop 'lib_time.o/codecsecdblinv        : *** ERROR !! Program aborted !'
                              endif

      im= int(toto/60.d0)
      toto=toto-dble(im*60)
      if(im.lt.0.or.im.gt.59) then
                              print*,'***/ NBDAY,IH,IM=',nbday,ih,im
      write(*,*) 'CODECSECDBLINV *** ABORTED ! ERROR ON IM                ***'
      stop 'lib_time.o/codecsecdblinv        : *** ERROR !! Program aborted !'
                              endif

      is= int(toto)
      toto=toto-dble(is)
      if(is.lt.0.or.is.gt.59) then
                           print*,'***/ NBDAY,IH,IM,IS=',nbday,ih,im,is
      write(*,*) 'CODECSECDBLINV *** ABORTED ! ERROR ON IS                ***'
      stop 'lib_time.o/codecsecdblinv        : *** ERROR !! Program aborted !'
                              endif

      ims= int(toto*1000.d0)
      toto=toto-dble(ims)/1000.d0
      if(ims.lt.0.or.ims.gt.999) then
                                print*,'***/ IH,IM,IS,IMS=',ih,im,is,ims
      write(*,*) 'CODECSECDBLINV *** ABORTED ! ERROR ON IMS               ***'
      stop 'lib_time.o/codecsecdblinv        : *** ERROR !! Program aborted !'
                              endif

      imc= int(toto*1000000.d0)
      if(imc.lt.0.or.imc.gt.999) then
                                 print*,'***/ IMC=',imc
      write(*,*) 'CODECSECDBLINV *** ABORTED ! ERROR ON IMC               ***'
      stop 'lib_time.o/codecsecdblinv        : *** ERROR !! Program aborted !'
                              endif

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine codoty(imonth,iday,iyear,idoty)
!
!     ------------------------------------------------------------------
! *   Object : compute_day_of_the_year with idoty=1 for january 1
! *   Class  : calendar transformations
! *   Author : P. Robert, CRPE, 1993 Jul.
! *   Comment: extracted from ROCOTLIB V 1.3 July 2000
!     ------------------------------------------------------------------

!     input : imonth,iday,iyear    ex: 10,17,1990
!     output: idoty                ex: 290


      dimension month(12)
      data month/31,28,31,30,31,30,31,31,30,31,30,31/

      call coleapyear(iyear,ily)

      if(ily.eq.1) then
                   month(2)=29
                   else
                   month(2)=28
                   endif
      if(imonth.lt.1.or.imonth.gt.12) then
                                print*, 'imonth must be between 1 or 12'
      write(*,*) 'CODOTY      *** ABORTED ! IMONTH MUST BE >1 AND <12  ***'
      stop 'lib_time.o/codoty                : *** ERROR !! Program aborted !'
                                      endif

      if(iday.gt.month(imonth)) then
                  print*,'***/ THIS MONTH HAS ONLY',month(imonth),'DAYS'
      write(*,*) 'CODOTY      *** ABORTED ! WRONG NUMBER OF DAYS       ***'
      stop 'lib_time.o/codoty                : *** ERROR !! Program aborted !'
                                endif

      idoty=iday
      do 10 i=1,imonth-1
      idoty=idoty+month(i)
   10 continue

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine coforstr(str, format)
!
!     ------------------------------------------------------------------
! *   Object : Renvoie le format associe aux chiffres d une string
! *   Class  : Utilitaires
! *   Author : J. Ahmad,  CETP, 2005
!     revision P. Robert, Mars 2011
!     ------------------------------------------------------------------

!     Declarations
!     ------------
      character*(*) str, format
      character*(255) costr, tstr
      character*(10) for(255)
      data for/255*' '/
      character*(1) type
      logical fin
      integer w, d, itf
!     ------------

!     recopie str pour traitement et init.
      costr=str
      fin=.false.
      itf=1

!     boucle de traitement
!     ********************

 10   if (.not. fin) then
!        longueur utile de la chaine
         iLstr=LEN_TRIM(costr)
         iBhead=LEN_TRIM(costr)-LEN_TRIM(ADJUSTL(costr))
!        calcul les blancs en debut de chaine
      !  call strblh(costr, iBhead)
!        cherche le prochain separateur
      !  call strpos(costr(iBhead+1:iLstr), ' ', iF1Ch)
         iF1Ch=INDEX(ADJUSTL(costr),' ')
!        cas du chiffre en fin de chaine
         if ((iLstr.ne.0) .and. (iF1Ch.eq.0)) then
            iF1Ch=iLstr+1-iBhead
         endif

!        calcul le format si la chaine n est pas vide
!        --------------------------------------------

         if ((iLstr.ne.0)) then
!           on recupere le chiffre
            tstr=costr(1:iF1Ch-1+iBhead)
!           on sort le 1 chiffre de la chaine
            costr=costr(iF1Ch+iBhead:iLstr)

!           calcul le format
!           oooooooooooooooo

!           calcul la longueur
            tstr=ADJUSTL(tstr)
            w=LEN_TRIM(tstr)
!           cherche si tstr est integer ou float ou real
            iPosPoi=INDEX(tstr(1:w), '.')
            iPosE  =INDEX(tstr(1:w), 'E')
            iPosPe =INDEX(tstr(1:w), 'e')
            if ((iPosPoi.eq.0).and.((iPosE.eq.0).or.(iPose.eq.0))) then
!              tstr est integer
               type='I'
               for(itf)=''
               if (w.lt.10) then
                  write(for(itf), '(a1,i1)') type, w
               else if ((w.lt.100).and.(w.ge.10)) then
                  write(for(itf), '(a1,i2)') type, w
               endif
               itf=itf+1
            else if ((iPosPoi.ne.0).and.(iPosE.eq.0).and.(iPosPe.eq.0)) &
                    then
!              tstr est un float
               type='F'
               for(itf)=''
               d=w-(iPosPoi+iBhead)
               if ((w.lt.10).and.(d.lt.10)) then
                  write(for(itf), '(a1,i1,a1,i1)') type, w, '.', d
               else if ((w.lt.100).and.(w.ge.10).and.(d.lt.10)) then
                  write(for(itf), '(a1,i2,a1,i1)') type, w, '.', d
               else if ((w.lt.10).and.(d.ge.10)) then
                  write(for(itf), '(a1,i1,a1,i2)') type, w, '.', d
               else if ((w.lt.100).and.(w.ge.10).and.(d.ge.10)) then
                  write(for(itf), '(a1,i2,a1,i2)') type, w, '.', d
               endif
               itf=itf+1
            else if ((iPosE.ne.0).or.(iPosPe.ne.0)) &
                    then
!              tstr est un real
               type='E'
               for(itf)=''
               d=iPosE+iPosPe-1-iPosPoi
               if (iPosPoi.eq.0) d=0
               if ((w.lt.10).and.(d.lt.10)) then
                  write(for(itf), '(a1,i1,a1,i1)') type, w, '.', d
               else if ((w.lt.100).and.(w.ge.10).and.(d.lt.10)) then
                  write(for(itf), '(a1,i2,a1,i1)') type, w, '.', d
               else if ((w.lt.10).and.(d.ge.10)) then
                  write(for(itf), '(a1,i1,a1,i2)') type, w, '.', d
               else if ((w.lt.100).and.(w.ge.10).and.(d.ge.10)) then
                  write(for(itf), '(a1,i2,a1,i2)') type, w, '.', d
               endif
               itf=itf+1
            endif
!           oooooooooooooooo

         else
            fin=.true.
         endif
!        --------------------------------------------

         goto 10
      endif
!     ********************

!     transfert des formats du tableau dans une chaine et unification
!     ***************************************************************
      format='('
      i=1

!     boucle de traitement de tous les formats dans le tableaux
!     ---------------------------------------------------------
 20   if (i.lt.itf) then
         j=i
         iNbEqu=1

!        on cherche combien de redodance
!        oooooooooooooooooooooooooooooooo
 30      if (for(j).eq.for(j+1))then
            iNbEqu=iNbEqu+1
            j=j+1
            goto 30
         endif
!        oooooooooooooooooooooooooooooooo

!        on recale en fonction des redondances l indice de boucle
         i=i+iNbEqu

         iUtilAllFor=LEN_TRIM(format)
!        (1 <= redondance < 10) => format=(i1,a,...)
         if ((iNbEqu.lt.10).and.(iNbEqu.ge.1)) then
            write(tstr, '(i1)') iNbEqu
            iUtil1For=LEN_TRIM(for(i-iNbEqu))
            format=format(1:iUtilAllFor)//tstr
            iUtilAllFor=iUtilAllFor+1
            format=format(1:iUtilAllFor)//for(i-iNbEqu)(1:iUtil1For)
            if (i.lt.itf) then
               format=format(1:iUtilAllFor+iUtil1For)//','
            endif
!        (10 <= redondance < 100) => format=(i2,a,...)
         else if ((iNbEqu.lt.100).and.(iNbEqu.ge.10)) then
            write(tstr, '(i2)') iNbEqu
            iUtil1For=LEN_TRIM(for(i-iNbEqu))
            format=format(1:iUtilAllFor)//tstr
            iUtilAllFor=iUtilAllFor+2
            format=format(1:iUtilAllFor)//for(i-iNbEqu)(1:iUtil1For)
            if (i.lt.itf) then
               format=format(1:iUtilAllFor+iUtil1For)//','
            endif
         endif

         goto 20
      endif
!     ---------------------------------------------------------
      iUtilAllFor=LEN_TRIM(format)
      format=format(1:iUtilAllFor)//')'

      end

!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX

      subroutine cojd00(iyear,imonth,iday,jd00)

!     ------------------------------------------------------------------
! *   Object : compute_julian_day_2000 with jd00=0 for january 1, 2000
! *   Class  : calendar transformations
! *   Author : P. Robert, CETP, 2000 Jul.
! *   Comment: extracted from ROCOTLIB V 1.3
!     ------------------------------------------------------------------

!     input : imonth,iday,iyear   ex: 10,17,2001
!     output: jd00 (may be negative)

      if(iyear.lt.1950) then
                    print*, '*** cojd00:iyear must be grather than 1950'
      write(*,*) 'COJD00         *** ABORTED ! IYEAR MUST BE > 1950       ***'
      stop 'lib_time.o/cojd00                : *** ERROR !! Program aborted !'
                        endif

      call cojd50(iyear,imonth,iday,jd50)

      jd00= jd50 - 18262

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine cojd50(iyear,imonth,iday,jd50)

!     ------------------------------------------------------------------
! *   Object : compute_julian_day_1950 with jd50=0 for january 1, 1950
! *   Class  : calendar transformations
! *   Author : P. Robert, CRPE, 1993 Jul.
! *   Comment: extracted from ROCOTLIB V 1.3 July 2000
!     ------------------------------------------------------------------

!     input : imonth,iday,iyear   ex: 10,17,1990
!     output: jd50
!
! *** test of validate year
!
      if(iyear.lt.1950) then
                   print*, '*** cojd50: iyear must be grather than 1950'
      stop 'lib_time.o/cojd50                : *** ERROR !! Program aborted !'
                        endif
!
! ***  computation of Julian day taking into account leap years
!
      call codoty(imonth,iday,iyear,idoty)

      jd50=idoty-1
      do 10 i=1950,iyear-1
      call coleapyear(i,ily)
      if(ily.eq.1) then
                   jd50=jd50+366
                   else
                   jd50=jd50+365
                   endif
   10 continue

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine coleapyear(iyear,ileap)

! ----------------------------------------------------------------------
!
! *   Class  : calendar modules of Rocotlib Software
! *   Object : compute_leap_year with ileap=1 for leap year, 0 if not
! *   Author : P. Robert, CRPE, 1992
! *   Comment: none
!
! *   input  : iyear (ex: 1980)
! *   output : ileap (1 or 0 if iyear is or not a leap year)
!
! ----------------------------------------------------------------------
!
      if(iyear.lt.1900) then
                    print*, '*** coleapyear: iyear must be such as 19XX'
      write(*,*) 'COLEAPYEAR    *** ABORTED ! IYEAR < 1900               ***'
      stop 'lib_time.o/coleapyear            : *** ERROR !! Program aborted !'
                        endif

      ir=iyear-(iyear/4)*4
      if(ir.eq.0) then
                  ileap=1
                  else
                  ileap=0
                  endif

      is=iyear-(iyear/100)*100
      if(is.eq.0) then
                  ir=iyear-(iyear/400)*400
                  if(ir.eq.0) then
                              ileap=1
                              else
                              ileap=0
                              endif
                  else
                  return
                  endif

      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine comilday(ih,im,is,ims, milday)
!
!     ------------------------------------------------------------------
! *   Object : calcule la milliseconde du jour
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001 Jan.
!     ------------------------------------------------------------------
!
      milday= ih*3600000 +im*60000 +is*1000 +ims

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine comildayinv(milday,ih,im,is,ims)

!     ------------------------------------------------------------------
! *   Object : convertie la milliseconde du jour en ih,im,is,ims
! *   Class  : depouillement specifique Roproc_Wave
! *   Author : P. Robert, CETP, 2001 Jan.
!     ------------------------------------------------------------------
!

      ih= milday/3600000
      irest=milday-ih*3600000

      im= irest/60000
      irest=irest-im*60000

      is= irest/1000
      irest=irest-is*1000

      ims= irest

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine diff_datiso(date1,date2,secdif)
!
!     ------------------------------------------------------------------
! *   Object : calcule la difference entre 2 dates ISO date2 -date1
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2002
!     ------------------------------------------------------------------
!
      character*(*) date1,date2
      double precision secdif,sec1,sec2

      call decode_datiso(date1,iyr1,imon1,iday1,ih1,im1,is1,ims1,imc1)
      call decode_datiso(date2,iyr2,imon2,iday2,ih2,im2,is2,ims2,imc2)

      call cojd50(iyr1,imon1,iday1,jd501)
      call cojd50(iyr2,imon2,iday2,jd502)

      call codecsecdbl(0,ih1,im1,is1,ims1,imc1,sec1)
      call codecsecdbl(0,ih2,im2,is2,ims2,imc2,sec2)

      secdif= dble((jd502-jd501)*24*3600) + sec2-sec1

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine compare_datiso(datiso1,datiso2,icomp)
!
!     ------------------------------------------------------------------
! *   Object : compare 2 dates ISO ; if date2 > date1 icomp=1 else -1
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, ScientiDev, Jan 2021
!     ------------------------------------------------------------------
!
      character*(*) datiso1,datiso2
      character*8   date1,date2
      character*9   time1,time2

      icomp=0

!     les dates sont supposee de la forme 2001-09-23T12:45:00.123Z ou 123456Z

      date1=datiso1(1:4)//datiso1(6:7)//datiso1(9:10)
      date2=datiso2(1:4)//datiso2(6:7)//datiso2(9:10)

      read(date1,'(i8)') idate1
      read(date2,'(i8)') idate2

      if(idate2 .GT. idate1) then
         icomp=1
         return
      endif

      if(idate2 .LT. idate1) then
         icomp=-1
         return
      endif

! les dates sont egales, test que sur le temps

      time1=datiso1(12:13)//datiso1(15:16)//datiso1(18:19)//datiso1(21:23)
      time2=datiso2(12:13)//datiso2(15:16)//datiso2(18:19)//datiso2(21:23)

      read(time1,'(i9)') itime1
      read(time2,'(i9)') itime2

      if(itime2 .GT. itime1) then
         icomp=1
         return
      endif

      if(itime2 .LT. itime1) then
         icomp=-1
         return
      endif

! les temps sont egaux

      icomp=0

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine decode_datiso(datiso,iyear,imon,iday,ih,im,is,ims,imc)
!
!     ------------------------------------------------------------------
! *   Object : decode la date ISO en date et heure
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2001
!     ------------------------------------------------------------------
!
      character(len=*)   :: datiso
      character(len=255) :: ligne
      real(kind=4) :: sec
!
! *   input : datiso (cha)
! *   output: iyear,imon,iday,ih,im,is,ims,imc
!
! *   la date est supposee etre de la forme 2002-09-27T12:03:45.23465Z
!
!                    *********************
!
!     recherche du champ 'T' et du champ 'Z' de la date en format ISO
!
      nT=INDEX(datiso,'T')
      nZ=INDEX(datiso,'Z')

      if(nZ.eq. 0) then
                   print*, '*** error in decode_datiso'
                   print*, '***/ BAD DATE FORMAT: ',datiso
                   print*, '***/ len=',LEN(datiso),LEN_TRIM(datiso)
      write(*,*) 'DECODE_DATISO *** ABORTED ! ERROR ON ISO DATE, NO Z    ***'
      stop 'lib_time.o/decode_datiso         : *** ERROR !! Program aborted !'
                   endif

      ih=0
      im=0
      is=0
      ims=0
      imc=0
!
! *** cas ou on a que la date
!
      if(nZ.eq.11) then
                   read(datiso,200) iyear,imon,iday
                   return
                   endif
!
! *** verif que le champ Time existe
!
      if(nT.ne.11) then
                   print*, '*** error in decode_datiso'
                   print*,'***/ BAD DATE FORMAT: ',datiso
      write(*,*) 'DECODE_DATISO *** ABORTED ! ERROR ON ISO DATE FORMAT   ***'
      stop 'lib_time.o/decode_datiso         : *** ERROR !! Program aborted !'
                   endif
!
! *** verif que ih:im:is existe dans le champ Time
!
      if(nZ.lt.20) then
                   print*, '*** error in decode_datiso'
                   print*,'***/ BAD DATE FORMAT: ',datiso
      write(*,*) 'DECODE_DATISO *** ABORTED ! ERROR ON ISO DATE FORMAT   ***'
      stop 'lib_time.o/decode_datiso         : *** ERROR !! Program aborted !'
                   endif
!
! *** decodage de la date sauf les milllisec
!
      read(datiso,200, iostat=iosta) iyear,imon,iday,ih,im,is
      if(iosta /= 0 ) then
                      write(*,*) 'lib_time.o/decode_datiso : datiso=',trim(datiso)
                      go to 10
      endif
!
! *** retour si on a que ih:im:is
!
      if(nZ.eq.20) return
!
! *** calcul de la seconde decimale
!
      ligne=datiso(18:nZ-1)
      read(ligne,*,err=10) sec

      is=int(sec)
      ims=int((sec-float(is))*1000.)
      imc=int((sec-float(is))*1000. -float(ims))

  200 format(i4,5(1x,i2))

      return

 10   write(*,*) 'DECODE_DATISO *** ABORTED ! Input data have a bad format ***'
      stop 'lib_time.o/decode_datiso         : *** ERROR !! Program aborted !'
      end
!
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine encode_datiso(iyear,imon,iday,ih,im,is,ims,imc,datiso)
!
!     ------------------------------------------------------------------
! *   Object : encode la date ISO en date et heure
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2001
!     ------------------------------------------------------------------
!
      character*(*) datiso
!
! *   input : iyear,imon,iday,ih,im,is,ims,imc
! *   output: datiso (cha)
!
! *   la date sera de la forme 2002-09-27T12:03:45.234Z    pour imc <0
! *                et la forme 2002-09-27T12:03:45.234456Z pour imc >=0
!
!                    *********************
!
! *** verif qu'on a assez de caracteres disponibles
!
      nd=len(datiso)
!
      if(nd.lt.24) then
                   print*, '*** error in encode_datiso'
                   print*, '*** ABORTED !'
      write(*,*) 'ENCODE_DATISO *** ABORTED ! DATISO < 24 CHARACTERS     ***'
      stop 'lib_time.o/encode_datisos        : *** ERROR !! Program aborted !'
                   endif

      if(nd.lt.27.and.imc.ge.0) then
                   print*, '*** ABORTED !'
      write(*,*) 'ENCODE_DATISO *** ABORTED ! DATISO < 27 CHARACTERS     ***'
      stop 'lib_time.o/encode_datisos        : *** ERROR !! Program aborted !'
                   endif

      if(imc.ge.0) then
                   write(datiso,100) iyear,imon,iday,ih,im,is,ims,imc
                   else
                   write(datiso,200) iyear,imon,iday,ih,im,is,ims
                   endif

  100 format(i4.4,2('-',i2.2),'T',2(i2.2,':'),i2.2,'.',i3.3,i3.3,'Z')
  200 format(i4.4,2('-',i2.2),'T',2(i2.2,':'),i2.2,'.',i3.3,'Z')

      return
      end
!
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine encode_datpat(iyear,imon,iday,ih,im,is,ims,imus,datpat)
!
!     ------------------------------------------------------------------
! *   Object : cre la 'date Patrick' ex: '2000-09-13 12:09:56.868055'
! *   Class  : depouillement specifique Roproc_Vector
! *   Author : P. Robert, CETP, 2002 Sep.
!     ------------------------------------------------------------------
!
      character*(*) datpat
      character*27 datiso
!
!                    *********************
!
      call encode_datiso(iyear,imon,iday,ih,im,is,ims,imus,datiso)
      call clean_datiso(datiso,datpat)

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine gdatime(iyear,imon,iday,ih,im,is,ims)

!     ------------------------------------------------------------------
! *   Object : donne la date et le temps au moment du call
! *   Class  : depouillement specifique Roproc
! *   Author : J. Ahmad,  CETP, 2006
!     ------------------------------------------------------------------
!
      implicit none
      character(len=8) :: date
      character(len=10) :: time
      character(len=5) :: zone
      integer, dimension(8) :: values
      integer :: iyear,imon,iday,ih,im,is,ims

      call date_and_time(date, time, zone, values)
      iyear=values(1)
      imon=values(2)
      iday=values(3)
      ih=values(5)
      im=values(6)
      is=values(7)
      ims=values(8)

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine gdatiso(datiso)

!     ------------------------------------------------------------------
! *   Object : donne la date ISO au moment du call
! *   Author : P. Robert, LPP,  2011 Mar.
!     ------------------------------------------------------------------
!
      implicit none
      character(len=8)  :: date
      character(len=10) :: time
      character(len=5)  :: zone
      character(len=*) :: datiso
      integer, dimension(8) :: values

      if(len(datiso).lt.24) then
                   print*, '*** error in gdatiso'
                   print*, '*** ABORTED !'
            write(*,*) 'gdatiso *** ABORTED ! DATISO < 24 CHARACTERS     ***'
      stop 'lib_time.o/gdatiso               : *** ERROR !! Program aborted !'
      endif

      call date_and_time(date, time, zone, values)
      datiso=date(1:4)//'-'//date(5:6)//'-'//date(7:8)//'T'// &
             time(1:2)//':'//time(3:4)//':'//time(5:10)//'Z'

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine print_date_time(com)

!     ------------------------------------------------------------------
! *   Object : print le CPU time ecoule depuis le dernier appel
! *   Author : P. Robert, LPP,  2011 Mar.
!     ------------------------------------------------------------------
!

      character*(*) com
      character*10 date,time,zone
      integer values(20)
      real secprev, seccpu
      integer iter

      save secprev
      save iter

      data secprev /0./
      data iter /0/

!     ------------------------------------------------------------------
!     print CPU time since last call
!     ------------------------------------------------------------------

      iter=iter +1
      if(iter.gt.10) return

      call date_and_time(date,time,zone,values)
      call cpu_time(seccpu)

      write(*,*) '_________________________________'
      write(*,1) com
      write(*,1) 'clock time= ',date,' / ',time
      write(*,*) 'cpu   time=',seccpu,'  delta CPU =',seccpu-secprev
      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

      secprev=seccpu

    1 format(1x,a,a8,2a)

      return
      end
!
!     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX

      subroutine read_date(prompt,iday,imonth,iyear)
!
!     ------------------------------------------------------------------
! *   Object : lit la date depuis l'input et test sa validite
! *   Class  : Utilitaire de Rocotlib
! *   Author : P. Robert, CRPE, 1993
!     ------------------------------------------------------------------
!
      character*(*) prompt
      dimension month(12)
      data month/31,28,31,30,31,30,31,31,30,31,30,31/
!
!                    *********************

!     test if imonth is not greater than 12
!     test if iday is not greather then lengh of the month,
!                         takink into account the leap years.
!     year must be greather or equal to 1900
!
!     input : iyear,imonth,iday
!     output: print error if date is not valid, and ask again
!
!
   10 continue
      print*, 'iyear,imonth,iday ? (ex: 2001 09 24)'
      print 100, prompt
      read *,  iyear,imonth,iday

      if(iyear.lt.1900) then
                        print*, 'iyear doit etre superieur a 1900'
                        print*, 'on recommence...'
                        go to 10
                        endif

      call coleapyear(iyear,ily)

      if(ily.eq.1) then
                   month(2)=29
                   else
                   month(2)=28
                   endif

      if(imonth.lt.1.or.imonth.gt.12) then
                     print*, 'imonth must be between 1 or 12 please'
                     print*, 'again...'
                     go to 10
                                      endif

      if(iday.gt.month(imonth)) then
                print*
                print*, 'this month has only',month(imonth),'days'
                print*, 'again...'
                go to 10
                                endif

  100 format(a)
      return
      end
!
! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX
!
      subroutine read_time(prompt,ih,im,is)
!
!     ------------------------------------------------------------------
! *   Object : lit l'heure depuis l'input et test sa validite
! *   Class  : Utilitaire de Rocotlib
! *   Author : P. Robert, CRPE, 1993
!     ------------------------------------------------------------------
!
!     read hour, minute and second and verifie validity
!     ih must be between 1 and 23, im and is between 1 and 59
!
!     input : ih,im,is
!     output: print error if time is not valid, and ask again
!
!                    *********************
!
      character*(*) prompt

   10 continue
      print*, 'hour, minute, second ? (ex: 10,45,50)'
      print 100, prompt
      read *, ih,im,is

      if(ih.lt.0.or.ih.gt.24) then
                              print*, 'hour between 0 and 24 please'
                              print*, 'again...'
                              go to 10
                              endif

      if(ih.eq.24) then
                   print*, 'hour=24, => min, sec are set to zero'
                   im=0
                   is=0
                   return
                   endif

      if(im.lt.0.or.im.gt.59) then
                              print*, 'minute between 0 and 59 please'
                              print*, 'again...'
                              go to 10
                              endif

      if(is.lt.0.or.is.gt.59) then
                              print*, 'second between 0 and 59 please'
                              print*, 'again...'
                              go to 10
                              endif

  100 format(a)

      return
      end

! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX0XX

