pywafo/wafo/source/cov2XXXpdf/cov2tccpdf.f

      PROGRAM sp2tccpdf
C***********************************************************************
C     This program computes:                                           *
C                                                                      *
C     density of     T=  T_1+T_2 in a gaussian process i.e.            *
C                                                                      *
C      wavelengthes for crests <h1 and troughs >h2                     *    
C                                                                      *
C     Sylvie  and Igor 7 dec. 1999                                    *
C***********************************************************************
      use GLOBALDATA, only : Nt,Nj,Nd,Nc,Ntd,Ntdc,NI,Mb,
     &   NIT,Nx,TWOPI,XSPLT,SCIS,NSIMmax,COV
      use rind
      IMPLICIT NONE
      double precision, dimension(:,:),allocatable :: BIG
      double precision, dimension(:,:),allocatable :: ansr
      double precision, dimension(:  ),allocatable :: ex,CY1,CY2
      double precision, dimension(:,:),allocatable :: xc
      double precision, dimension(:  ),allocatable :: fxind,h1,h2
      double precision, dimension(:  ),allocatable :: hh1,hh2
      double precision, dimension(:  ),allocatable :: R0,R1,R2
      double precision             ::CC,U,XddInf,XdInf,XtInf  
      double precision, dimension(:,:),allocatable :: a_up,a_lo
      integer         , dimension(:  ),allocatable :: seed
      integer ,dimension(7) :: indI
      integer :: Ntime,tn,ts,speed,ph,seed1,seed_size,Nx1,Nx2,N0
      integer :: icy,icy2
      double precision :: ds,dT ! lag spacing for covariances 
! DIGITAL:
! f90 -g2 -C -automatic -o ~/WAT/V4/sp2tthpdf1.exe rind49.f sp2tthpdf1.f
! SOLARIS:
!f90 -g -O -w3 -Bdynamic -fixed -o ../sp2tthpdf.exe rind49.f sp2tthpdf1.f

      !print *,'enter sp2thpdf'
      CALL INIT_LEVELS(U,Ntime,N0,NIT,speed,SCIS,seed1,Nx1,Nx2,dT)
      
      !print *,'U,Ntime,NIT,speed,SCIS,seed1,Nx,dT'
      !print *,U,Ntime,NIT,speed,SCIS,seed1,Nx,dT
      !Nx1=1
      !Nx2=1

      Nx=Nx1*Nx1 
      !print *,'NN',Nx1,Nx2,Nx
      
      
      !XSPLT=1.5d0
      if (SCIS.GT.0) then
        allocate(COV(1:Nx))
        call random_seed(SIZE=seed_size) 
        allocate(seed(seed_size)) 
        call random_seed(GET=seed(1:seed_size))  ! get current seed
        seed(1)=seed1                            ! change seed
        call random_seed(PUT=seed(1:seed_size)) 
        deallocate(seed)
      endif
      CALL INITDATA(speed)  
      !print *,ntime,speed,u,NIT
      allocate(R0(1:Ntime+1))
      allocate(R1(1:Ntime+1))
      allocate(R2(1:Ntime+1))
      
      allocate(h1(1:Nx1))
      allocate(h2(1:Nx2))
      CALL INIT_AMPLITUDES(h1,Nx1,h2,Nx2)
      CALL INIT_COVARIANCES(Ntime,R0,R1,R2)
      

      allocate(hh1(1:Nx))
      allocate(hh2(1:Nx))
      !h transformation
      do icy=1,Nx1
         do icy2=1,Nx2
         hh1((icy-1)*Nx2+icy2)=h1(icy);
         hh2((icy-1)*Nx2+icy2)=h2(icy2); 
         enddo 
      enddo

      Nj=0
      indI(1)=0

C     ***** The bound 'infinity' is set to 10*sigma *****
      XdInf=10.d0*SQRT(-R2(1))
      XtInf=10.d0*SQRT(R0(1))
      !h1(1)=XtInf
      !h2(1)=XtInf
      ! normalizing constant
      CC=TWOPI*SQRT(-R0(1)/R2(1))*exp(u*u/(2.d0*R0(1)) )
      allocate(CY1(1:Nx)) 
      allocate(CY2(1:Nx)) 
      do icy=1,Nx
        CY1(icy)=exp(-0.5*hh1(icy)*hh1(icy)/100)/(10*sqrt(twopi))
        CY2(icy)=exp(-0.5*hh2(icy)*hh2(icy)/100)/(10*sqrt(twopi))
      enddo
      !print *,CY1
      allocate(ansr(1:Ntime,1:Nx))
      ansr=0.d0
      allocate(fxind(1:Nx))    
      fxind=0.d0 
   
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Y={X(t2)..,X(ts),..X(tn-1)||X'(ts) X'(t1) X'(tn)||Y1 Y2 X(ts) X(t1) X(tn)} !!
! = [Xt                          Xd                    Xc]                   !!
!                                                                            !!
! Nt=tn-2, Nd=3, Nc=2+3                                                      !!
!                                                                            !!
! Xt= contains Nt time points in the indicator function                      !!
! Xd=    "     Nd    derivatives                                             !!
! Xc=    "     Nc    variables to condition on                               !!
! (Y1,Y2) dummy variables ind. of all other v. inputing h1,h2 into rindd     !!
!                                                                            !!
! There are 6 ( NI=7) regions with constant bariers:                         !!
! (indI(1)=0);     for i\in (indI(1),indI(2)] u<Y(i)<h1                      !!
! (indI(2)=ts-2);  for i\in (indI(2),indI(2)], inf<Y(i)<inf (no restr.)      !!
! (indI(3)=ts-1);  for i\in (indI(3),indI(4)], h2 <Y(i)<u                    !!
! (indI(4)=Nt)  ;  for i\in (indI(4),indI(5)], Y(i)<0 (deriv. X'(ts))        !!
! (indI(5)=Nt+1);  for i\in (indI(5),indI(6)], Y(i)>0 (deriv. X'(t1))        !!
! (indI(6)=Nt+2);  for i\in (indI(6),indI(7)], Y(i)>0 (deriv. X'(tn))        !!
! (indI(7)=Nt+3);  NI=7.                                                     !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      
      NI=7; Nd=3
      Nc=5; Mb=3
      allocate(a_up(1:Mb,1:(NI-1)))
      allocate(a_lo(1:Mb,1:(NI-1)))
      a_up=0.d0
      a_lo=0.d0
      allocate(BIG(1:(Ntime+Nc+1),1:(Ntime+Nc+1))) 
      ALLOCATE(xc(1:Nc,1:Nx))
      allocate(ex(1:(Ntime+Nc+1)))
      !print *,size(ex),Ntime
      ex=0.d0
      !print *,size(ex),ex
      xc(1,1:Nx)=hh1(1:Nx)
      xc(2,1:Nx)=hh2(1:Nx)
      xc(3,1:Nx)=u
      xc(4,1:Nx)=u
      xc(5,1:Nx)=u
         ! upp- down- upp-crossings at t1,ts,tn
       
        a_lo(1,1)=u
        a_up(1,2)=XtInf   ! X(ts) is redundant  
        a_lo(1,2)=-Xtinf
        a_up(1,3)=u
   
 
        a_lo(1,4)=-XdInf
        a_up(1,5)= XdInf
        a_up(1,6)= XdInf  

        a_up(2,1)=1.d0
        a_lo(3,3)=1.d0 !signe a voir!!!!!!
!        print *,a_up
!        print *,a_lo
      do tn=N0,Ntime,1
!      do tn=Ntime,Ntime,1
        Ntd=tn+1
        Nt=Ntd-Nd
        Ntdc=Ntd+Nc
        indI(4)=Nt
        indI(5)=Nt+1
        indI(6)=Nt+2
        indI(7)=Ntd
        if (SCIS.gt.0) then
           if (SCIS.EQ.2) then           
              Nj=max(Nt,0)
           else
              Nj=min(max(Nt-5, 0),0)
           endif
        endif
        do ts=3,tn-2
         !print *,'ts,tn' ,ts,tn,Ntdc
         CALL COV_INPUT(Big(1:Ntdc,1:Ntdc),tn,ts,R0,R1,R2)!positive wave period
         indI(2)=ts-2
         indI(3)=ts-1
         

         CALL RINDD(fxind,Big(1:Ntdc,1:Ntdc),ex(1:Ntdc),
     &              xc,indI,a_lo,a_up)
         
        ds=dt
         do icy=1,Nx
         ! ansr(tn,:)=ansr(tn,:)+fxind*CC*ds./(CY1.*CY2)
         ansr(tn,icy)=ansr(tn,icy)+fxind(icy)*CC*ds/(CY1(icy)*CY2(icy))
         enddo
        enddo ! ts
        print *,'Ready: ',tn,' of ',Ntime

      enddo !tn
      !print *,'ansr',ansr
 300  open (unit=11, file='dens.out',  STATUS='unknown')
      !print *, ansr
      do ts=1,Ntime
         do ph=1,Nx
            !write(11,*)  ansr(ts,ph),hh1(ph),hh2(ph)
            write(11,111)  ansr(ts,ph)

         enddo
      enddo
 111  FORMAT(2x,F12.8)  
      close(11)
 900  deallocate(big)
      deallocate(fxind)
      deallocate(ansr)
      deallocate(xc)
      deallocate(ex)
      deallocate(R0)
      deallocate(R1)
      deallocate(R2)
      if (allocated(COV) ) then
         deallocate(COV)
      endif
        deallocate(h1)
        deallocate(h2)
        deallocate(hh1)
        deallocate(hh2)
        deallocate(a_up)
        deallocate(a_lo)
      stop
      !return

      CONTAINS
      
    
            
      SUBROUTINE INIT_LEVELS
     & (U,Ntime,N0,NIT,speed,SCIS,seed1,Nx1,Nx2,dT)
      IMPLICIT NONE
      integer, intent(out):: Ntime,N0,NIT,speed,Nx1,Nx2,SCIS,seed1
      double precision ,intent(out) :: U,dT
     

      OPEN(UNIT=14,FILE='reflev.in',STATUS= 'UNKNOWN') 
      
      READ (14,*) U
      READ (14,*) Ntime
      READ (14,*) N0
      READ (14,*) NIT
      READ (14,*) speed   
      READ (14,*) SCIS   
      READ (14,*) seed1   


        READ (14,*) Nx1,Nx2
        READ (14,*) dT
        if (Ntime.lt.5) then
           print *,'The number of wavelength points is too small, stop'
           stop
        end if
      
      CLOSE(UNIT=14)
       
      RETURN
      END SUBROUTINE INIT_LEVELS
 
C******************************************************
      SUBROUTINE INIT_AMPLITUDES(h1,Nx1,h2,Nx2)      
      IMPLICIT NONE
      double precision, dimension(:), intent(out) :: h1,h2    
      integer, intent(in) :: Nx1,Nx2
      integer :: ix
      
 
      OPEN(UNIT=4,FILE='h.in',STATUS= 'UNKNOWN')

C
C Reading in amplitudes
C
      do ix=1,Nx1
        READ (4,*) H1(ix)
      enddo
      do ix=1,Nx2
        READ (4,*) H2(ix)
      enddo
      CLOSE(UNIT=4)
      
      RETURN
      END SUBROUTINE INIT_AMPLITUDES

C**************************************************

C***********************************************************************
C***********************************************************************
       
      SUBROUTINE INIT_COVARIANCES(Ntime,R0,R1,R2)
      IMPLICIT NONE
      double precision, dimension(:),intent(out) :: R0,R1,R2
      integer,intent(in) :: Ntime
      integer :: i
      open (unit=1, file='Cd0.in',STATUS='unknown')
      open (unit=2, file='Cd1.in',STATUS='unknown')
      open (unit=3, file='Cd2.in',STATUS='unknown')

      do i=1,Ntime
         read(1,*) R0(i)
         read(2,*) R1(i)
         read(3,*) R2(i)
      enddo
      close(1)
      close(2)
      close(3)
      
      return
      END SUBROUTINE INIT_COVARIANCES
      
C***********************************************************************
C***********************************************************************

C**********************************************************************

      SUBROUTINE COV_INPUT(BIG,tn,ts, R0,R1,R2)
      IMPLICIT NONE
      double precision, dimension(:,:),intent(inout) :: BIG
      double precision, dimension(:),intent(in) :: R0,R1,R2
      integer ,intent(in) :: tn,ts
      integer :: i,j,Ntd1,N !=Ntdc
      double precision :: tmp 
! the order of the variables in the covariance matrix
! are organized as follows: 
! 
! ||X(t2)..X(ts),..X(tn-1)||X'(ts) X'(t1) X'(tn)||Y1 Y2 X(ts) X(t1) X(tn)|| 
! = [Xt                          Xd                    Xc]
! where 
!
! Xt= time points in the indicator function
! Xd= derivatives
! Xc=variables to condition on

! Computations of all covariances follows simple rules: Cov(X(t),X(s))=r(t,s),
! then  Cov(X'(t),X(s))=dr(t,s)/dt.  Now for stationary X(t) we have
! a function r(tau) such that Cov(X(t),X(s))=r(s-t) (or r(t-s) will give the same result).
!
! Consequently  Cov(X'(t),X(s))    = -r'(s-t)    = -sign(s-t)*r'(|s-t|)
!               Cov(X'(t),X'(s))   = -r''(s-t)   = -r''(|s-t|)
!               Cov(X''(t),X'(s))  =  r'''(s-t)  =  sign(s-t)*r'''(|s-t|)
!               Cov(X''(t),X(s))   =  r''(s-t)   =   r''(|s-t|)
!               Cov(X''(t),X''(s)) =  r''''(s-t) = r''''(|s-t|)

      Ntd1=tn+1
      N=Ntd1+Nc
      do i=1,tn-2
      !cov(Xt)
         do j=i,tn-2
           BIG(i,j) = R0(j-i+1) ! cov(X(ti+1),X(tj+1))
         enddo
      !cov(Xt,Xc)
	 BIG(i      ,Ntd1+1) = 0.d0          !cov(X(ti+1),Y1)  
         BIG(i      ,Ntd1+2) = 0.d0          !cov(X(ti+1),Y2)  
         BIG(i      ,Ntd1+4) = R0(i+1)       !cov(X(ti+1),X(t1))  
         BIG(tn-1-i ,Ntd1+5) = R0(i+1)       !cov(X(t.. ),X(tn))  

      !Cov(Xt,Xd)=cov(X(ti+1),x(tj)
         BIG(i,Ntd1-1)   =-R1(i+1)         !cov(X(ti+1),X'(t1))  
         BIG(tn-1-i,Ntd1)= R1(i+1)         !cov(X(ti+1),X'(tn)) 
      enddo
!cov(Xd)
      BIG(Ntd1  ,Ntd1  ) = -R2(1)
      BIG(Ntd1-1,Ntd1  ) = -R2(tn)        !cov(X'(t1),X'(tn))
      BIG(Ntd1-1,Ntd1-1) = -R2(1)
      BIG(Ntd1-2,Ntd1-1) = -R2(ts)        !cov(X'(ts),X'(t1))
      BIG(Ntd1-2,Ntd1-2) = -R2(1)
      BIG(Ntd1-2,Ntd1  ) = -R2(tn+1-ts)   !cov(X'(ts),X'(tn))

!cov(Xc)
      BIG(Ntd1+1,Ntd1+1) = 100.d0        ! cov(Y1 Y1) 
      BIG(Ntd1+1,Ntd1+2) = 0.d0          ! cov(Y1 Y2) 
      BIG(Ntd1+1,Ntd1+3) = 0.d0          ! cov(Y1 X(ts)) 
      BIG(Ntd1+1,Ntd1+4) = 0.d0          ! cov(Y1 X(t1)) 
      BIG(Ntd1+1,Ntd1+5) = 0.d0          ! cov(Y1 X(tn))
      BIG(Ntd1+2,Ntd1+2) = 100.d0        ! cov(Y2 Y2) 
      BIG(Ntd1+2,Ntd1+3) = 0.d0          ! cov(Y2 X(ts)) 
      BIG(Ntd1+2,Ntd1+4) = 0.d0          ! cov(Y2 X(t1)) 
      BIG(Ntd1+2,Ntd1+5) = 0.d0          ! cov(Y2 X(tn))

      BIG(Ntd1+3,Ntd1+3) = R0(1)        ! cov(X(ts),X (ts)
      BIG(Ntd1+3,Ntd1+4) = R0(ts)       ! cov(X(ts),X (t1))
      BIG(Ntd1+3,Ntd1+5) = R0(tn+1-ts)  ! cov(X(ts),X (tn))
      BIG(Ntd1+4,Ntd1+4) = R0(1)        ! cov(X(t1),X (t1)) 
      BIG(Ntd1+4,Ntd1+5) = R0(tn)       ! cov(X(t1),X (tn))
      BIG(Ntd1+5,Ntd1+5) = R0(1)        ! cov(X(tn),X (tn))
  

!cov(Xd,Xc)
      BIG(Ntd1  ,Ntd1+1) = 0.d0        !cov(X'(tn),Y1) 
      BIG(Ntd1  ,Ntd1+2) = 0.d0        !cov(X'(tn),Y2) 
      BIG(Ntd1-1  ,Ntd1+1) = 0.d0        !cov(X'(t1),Y1) 
      BIG(Ntd1-1  ,Ntd1+2) = 0.d0        !cov(X'(t1),Y2) 
      BIG(Ntd1-2  ,Ntd1+1) = 0.d0        !cov(X'(ts),Y1) 
      BIG(Ntd1-2  ,Ntd1+2) = 0.d0        !cov(X'(ts),Y2) 
  
      BIG(Ntd1  ,Ntd1+4) = R1(tn)        !cov(X'(tn),X(t1))     
      BIG(Ntd1  ,Ntd1+5) = 0.d0          !cov(X'(tn),X(tn))
      BIG(Ntd1-1,Ntd1+4) = 0.d0          !cov(X'(t1),X(t1))
      BIG(Ntd1-1,Ntd1+5) =-R1(tn)        !cov(X'(t1),X(tn))
      BIG(Ntd1  ,Ntd1+3) = R1(tn+1-ts)   !cov(X'(tn),X (ts))  
      BIG(Ntd1-1,Ntd1+3) =-R1(ts)        !cov(X'(t1),X (ts))   
      BIG(Ntd1-2,Ntd1+3) = 0.d0          !cov(X'(ts),X (ts)
      BIG(Ntd1-2,Ntd1+4) = R1(ts)        !cov(X'(ts),X (t1))
      BIG(Ntd1-2,Ntd1+5) = -R1(tn+1-ts)  !cov(X'(ts),X (tn))


        do i=1,tn-2
          j=abs(i+1-ts)
!cov(Xt,Xc)
          BIG(i,Ntd1+3)   = R0(j+1)      !cov(X(ti+1),X(ts))          
!Cov(Xt,Xd)
          if ((i+1-ts).lt.0) then
              BIG(i,Ntd1-2)  =  R1(j+1)
            else                         !cov(X(ti+1),X'(ts))  
              BIG(i,Ntd1-2)  = -R1(j+1)
          endif
      enddo
    
! make lower triangular part equal to upper 
      do j=1,N-1
        do i=j+1,N
           tmp =BIG(j,i)

           BIG(i,j)=tmp
        enddo
      enddo

C     write (*,10) ((BIG(j,i),i=N+1,N+6),j=N+1,N+6)
C 10  format(6F8.4)
      RETURN
      END  SUBROUTINE COV_INPUT

      SUBROUTINE COV_INPUT2(BIG,pt, R0,R1,R2)
      IMPLICIT NONE
      double precision, dimension(:,:), intent(out) :: BIG
      double precision, dimension(:), intent(in) ::  R0,R1,R2
      integer :: pt,i,j
! the order of the variables in the covariance matrix
! are organized as follows;
! X(t2)...X(tn-1) X'(t1) X'(tn) X(t1) X(tn) = [Xt Xd Xc]
! 
! where Xd is the derivatives 
!
! Xt= time points in the indicator function
! Xd= derivatives
! Xc=variables to condition on

!cov(Xc)
      BIG(pt+2,pt+2) = R0(1)
      BIG(pt+1,pt+1) = R0(1)
      BIG(pt+1,pt+2) = R0(pt)
!cov(Xd)
      BIG(pt,pt)     = -R2(1)
      BIG(pt-1,pt-1) = -R2(1)
      BIG(pt-1,pt)   = -R2(pt)
!cov(Xd,Xc)
      BIG(pt,pt+2)   =  0.d0
      BIG(pt,pt+1)   = R1(pt)
      BIG(pt-1,pt+2) = -R1(pt)
      BIG(pt-1,pt+1) =  0.d0
 
      if (pt.GT.2) then
!cov(Xt)
         do i=1,pt-2
           do j=i,pt-2
              BIG(i,j) = R0(j-i+1)
           enddo
        enddo
!cov(Xt,Xc)
        do i=1,pt-2
           BIG(i,pt+1)      = R0(i+1)
           BIG(pt-1-i,pt+2) = R0(i+1)
        enddo
!Cov(Xt,Xd)=cov(X(ti+1),x(tj))
        do i=1,pt-2
           BIG(i,pt-1)   = -R1(i+1)
           BIG(pt-1-i,pt)=  R1(i+1)
        enddo
      endif


      ! make lower triangular part equal to upper 
      do j=1,pt+1
         do i=j+1,pt+2
            BIG(i,j)=BIG(j,i)
         enddo
      enddo
C      write (*,10) ((BIG(j,i),i=N+1,N+6),j=N+1,N+6)
C 10   format(6F8.4)
      RETURN
      END  SUBROUTINE COV_INPUT2 


      END  PROGRAM  sp2tccpdf