! ------------------------------------------------------------------------------
!
! test program for mo_standard_score
!
! author: Matthias Zink
!
! created: May 2015
!
! ------------------------------------------------------------------------------

program test

  use mo_kind,           only: i4, sp, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_standard_score, only: standard_score, classified_standard_score

  implicit none

  real(dp),     dimension(9)    :: vec1       ! data array
  integer(i4),  dimension(9)    :: control    ! array with contral values
  integer(i4),  dimension(9)    :: classes    ! classes for classified_standard_score
  logical,      dimension(9)    :: masking    ! mask for excluding nodata values
  logical                       :: isgood
  real(sp), dimension(9) :: stmp
  real(dp), dimension(9) :: dtmp

  isgood = .true.

  vec1(:)    = (/12.0_dp,  4.0_dp, 15.0_dp, 17.0_dp, 10.0_dp,  2.0_dp,  1.0_dp, 11.0_dp, 20.0_dp/)

  masking = .TRUE.
  ! sp without mask
  ! standard_score
  control(:) = (/26518, -92813, 71267, 101100, -3315, -122645, -137562, 11602, 145849/)
  stmp = standard_score(real(vec1(:),sp)              )
  isgood  = isgood .and. all(nint(100000.0_sp * stmp) .EQ. control)
  if (.not. isgood) write(*,*) 'mo_standard_score 1'
  stmp = standard_score(real(vec1(:),sp), mask=masking)
  isgood  = isgood .and. all(nint(100000.0_sp * stmp) .EQ. control)
  if (.not. isgood) write(*,*) 'mo_standard_score 2'

  ! classified_standard_score
  classes =(/3,2,3,2,2,3,1,1,3/)
  control(:) = (/-3295, -97340, 36240, 102463, -5123, -135075, -70711, 70711, 102130/)
  stmp = classified_standard_score(real(vec1(:),sp), classes)
  isgood  = isgood .and. all(nint(100000.0_sp * stmp) .EQ. control)
  if (.not. isgood) write(*,*) 'mo_standard_score 3'

  masking(:) = (/.TRUE., .TRUE., .FALSE., .FALSE., .TRUE., .TRUE., .TRUE., .TRUE., .FALSE./)

  ! dp with mask
  ! standard_score
  control(:) = (/109170, -54585, 170578, 211517, 68231, -95524, -115993, 88701, 272925/)
  dtmp =            standard_score(     vec1(:),     mask=masking)
  isgood  = isgood .and. all(nint(100000.0_dp * dtmp) .EQ. control)
  if (.not. isgood) write(*,*) 'mo_standard_score 4'

  ! classified_standard_score
  control = (/70711, -70711, 0, 0, 70711, -70711, -70711, 70711, 0/)
  dtmp = classified_standard_score(vec1, classes, mask=masking)
  isgood  = isgood .and. all(nint(100000.0_dp * dtmp) .EQ. control)
  if (.not. isgood) write(*,*) 'mo_standard_score 5'

  if (isgood) then
     write(*,*) 'mo_standard_score ', color('o.k.', c_green)
  else
     write(*,*) 'mo_standard_score ', color('failed', c_red)
  endif
  !
end program test


      subroutine runY_0000l(k,l,Xtwiddle,Gtwiddle,Shat5zz,N0)
      implicit none
C---  Expression for D0000 obtained from 5.50, following the comment after
C     5.50 on how to add adding additional "00" pairs
C---  (similar to Eq. 5.56a but with "00" added)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat5zz(np,z2max,-2:0)

      do ep=-2,0

      Dv(dzzzzi(l)+N0,ep) = -(
     . -(Gtwiddle(k,1)*Shat5zz(1,z2(l,l),ep)
     .  +Gtwiddle(k,2)*Shat5zz(2,z2(l,l),ep)
     .  +Gtwiddle(k,3)*Shat5zz(3,z2(l,l),ep)
     .  +Xtwiddle(0,k)*Dv(dzzii(z2(l,l))+N0,ep)
     .  -Xtwiddle(0,0)*Dv(dzziii(z3(k,l,l))+N0,ep)))/(4d0*Gtwiddle(k,l))

      enddo

      return
      end


SUBROUTINE corr05(st11,st22,st12,efpst,c,prop,ierr,dstpl,fi)
!-------------------------------------------------------------------
!
!     Plastic Anisotropy Behaviour (Oller & Car)
!
!-------------------------------------------------------------------
IMPLICIT NONE

REAL (kind=8),INTENT(IN) :: prop(:), & !material properties
                            c(4)       !elasticity matrix (orthotropic)
REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12   !trial and corrected stresses
REAL (kind=8),INTENT(IN OUT) :: efpst  !effective plastic strain
                                         !(IN) present   (OUT) increment
REAL (kind=8),INTENT(OUT) :: dstpl(3), & !increment in plastic strains
                             fi          !equivalent stress
INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)

!local variables

 REAL (kind=8) :: c0,expn,aprim,e0,rfs
 REAL (kind=8) :: s11,s22,s12,yield,epbar,f0,a1,a2,a3, &
                  r1,r2,r3,ddl,rr,det,au1,au2,ap,acr

 REAL (kind=8), PARAMETER :: toler=1d-4, toler1=1d-6
 INTEGER (kind=4), PARAMETER :: miter=15

  INTEGER (kind=4) k,is

 !------------ begin

  !     setup initial yield FUNCTION radius

  c0   = prop(1)        !Initial yield or C0 constant
  e0   = prop(2)        !non-linear hardening
  expn = prop(3)        !exponent for non-linear hardening
  rfs  = prop(4)        !residual flow stress

  is = INT(prop(5))
  !   *****************************
  !               Initial Yield stress
  epbar = efpst
  SELECT CASE (is)
  CASE (1)
    yield = c0
    aprim = 0d0
  CASE (2)
    yield = c0 + e0*epbar     !linear hardening
    aprim = e0
  CASE (3)
    yield = c0*(e0+epbar)**expn            !non-linear (exponential) hardening
    aprim = expn*c0/(e0+epbar)**(1d0-expn) !derivative
  CASE (4)
    yield = c0+e0*epbar+(rfs-c0)*(1d0-1d0/EXP(expn*epbar)) !linear + saturation law hardening
    aprim = e0 + (rfs-c0)*expn/EXP(expn*epbar)             !derivative
  END SELECT

 !     calculate initial effective stress

 s11 = st11/prop(6)
 s22 = st22/prop(7)
 s12 = st12/prop(8)

 fi = SQRT(s11*s11-s11*s22+s22*s22+3d0*s12*s12)

 !     check initial yield FUNCTION

 f0 = fi-yield
 IF((f0-toler*fi) <=  0d0) THEN

   !   IF the point is elastic

   efpst = 0d0          !no plastic flow

  ELSE

   !   start iteration for satisfying consistency condition
    DO k = 1,miter
      ! derivative of yield function
      a1 = (s11 - s22/2d0)/fi
      a2 = (s22 - s11/2d0)/fi
      a3 = 3d0*s12/fi
      ! compute flow rule
      au1 = a1/prop(6)
      au2 = a2/prop(7)
      r1 = prop( 9)*au1+prop(10)*au2
      r2 = prop(11)*au1+prop(12)*au2
      r3 = prop(13)*a3/prop(8)
      ! derivative of effective plastic strain
      rr = (s11*r1+s22*r2+s12*r3)/fi
      ap = aprim*rr
      ! a : C(isotropic) : r
      acr = c(1)*(a1*r1+a2*r2)+c(2)*(a1*r2+a2*r1)+c(4)*a3*r3
      ddl = f0/(ap+acr)
      s11 = s11 - ddl*(c(1)*r1+c(2)*r2)
      s22 = s22 - ddl*(c(2)*r1+c(1)*r2)
      s12 = s12 - ddl*c(4)*r3
      !   calculate the effective plastic strain
      epbar = epbar + ddl*rr
      !   update the radius of the yield surface
      SELECT CASE (is)
      CASE (2)
        yield = c0 + e0*epbar     !linear hardening
      CASE (3)
        yield = c0*(e0+epbar)**expn            !non-linear (exponential) hardening
        aprim = expn*c0/(e0+epbar)**(1d0-expn) !derivative
      CASE (4)
        yield = c0+e0*epbar+(rfs-c0)*(1d0-1d0/EXP(expn*epbar)) !linear + saturation law hardening
        aprim = e0 + (rfs-c0)*expn/EXP(expn*epbar)           !derivative
      END SELECT
      !   calculate the effective stress
      fi = SQRT(s11*s11-s11*s22+s22*s22+3d0*s12*s12)
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      !  stress change
      a1 = st11 - s11*prop(6)
      a2 = st22 - s22*prop(7)
      a3 = st12 - s12*prop(8)
      !  assign corrected stresses
      st11 = s11*prop(6)
      st22 = s22*prop(7)
      st12 = s12*prop(8)
      ! increments in plastic strains
      det = c(1)*c(3) - c(2)*c(2)
      dstpl(1) = (a1*c(3)-c(2)*a2)/det
      dstpl(2) = (a2*c(1)-c(2)*a1)/det
      dstpl(3) = a3/c(4)
      efpst = epbar - efpst              !increment in effective plastic strain

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      !WRITE(lures,1000)ielem    !print element number
      ierr=1                    !set flag to error in plastic integration
    END IF
  END IF
  RETURN
  !1000 FORMAT(' Program will be stopped. No convergence in the return ', &
  !    &       'algorithm, elem. no:',i8)

END SUBROUTINE corr05


!***********************************************************************
! EoS Replacement based on Bahcall () for XNet 6.0 7/6/2010
! This file contains routines which calculate EoS quantites needed to
! calculate screening corrections for reaction rates.
!***********************************************************************

Subroutine eos_initialize
!-----------------------------------------------------------------------
! This routine initializes the EoS
!-----------------------------------------------------------------------
End Subroutine eos_initialize

Subroutine eos_cv(rho,t9,y,cv)
  Use nuclear_data
  Use constants
  Use controls
  Real(8), Intent(in) :: t9,rho,y(ny)
  Real(8), Intent(out) :: cv
  Real(8) :: ye,ytot,bkt,abar,zbar,z2bar,zibar,z53bar,z53(ny)
  Real(8) :: ae,gam,gam14,gam32,gamc2
  Real(8) :: eion,erad,ecoul
  Real(8) :: deiondt9,deraddt9,decouldt9
  Real(8), Parameter :: asig=8.56345d31
  Real(8), Parameter :: onethird=1./3.,twothird=2./3.,fivethird=5./3.
  Real(8), Parameter :: a1=0.898004,b1=0.96786,c1=0.220703,d1=-0.86097
  Real(8), Parameter :: a2=-0.86602540378,b2=0.29561,c2=1.9885

! Calculate Ye and other needed moments of the abundance distribution
  call y_moment(y,ye,ytot,abar,zbar,z2bar,zibar)

! Calculate energy derivatives (assume etot = eion + erad + ecoul) (ignore degenerate electron energy)
  bkt=bok*t9

  eion=1.5*bkt*ytot
  deiondt9=1.5*ytot*bok

  erad=asig*bkt*bkt*bkt*bkt/(rho*avn)
  deraddt9=4.0*erad/t9

  ae=(3./(4.*pi*avn*rho*ye))**onethird ! electron-sphere radius
  z53(1:ny)=zz(1:ny)**fivethird
  z53bar=sum(z53*y)/ytot
  gam=z53bar*e2/(ae*bkt) ! ionic Coulomb coupling parameter
  If(gam>=1.0) Then
    gam14=gam**0.25
    ecoul=(a1*gam+b1*gam14+c1/gam14+d1)*bkt*ytot
    decouldt9=ecoul/t9-bok*ytot*(a1*gam+0.25*(b1*gam14-c1/gam14))
  Else
    gam32=gam*sqrt(gam)
    gamc2=gam**c2
    ecoul=(a2*gam32+b2*gamc2)*bkt*ytot
    decouldt9=ecoul/t9-bok*ytot*(1.5*a2*gam32+b2*c2*gamc2)
  EndIf

  cv=deiondt9+deraddt9+decouldt9

  If(idiag>0) Write(lun_diag,'(a,5es12.5)') 'CV',t9,rho,ye,cv

  Return
End Subroutine eos_cv

Subroutine eos_interface(t9,rho,y,ye,ztilde,zinter,lambda0,gammae,dztildedt9)
!-----------------------------------------------------------------------
! This routine Bahcall's approach to calculate the factors needed for
! screening from the input temperature, density and composition.
!-----------------------------------------------------------------------
  Use constants
  Use controls
  Real(8), Intent(in) :: t9, rho, y(*)
  Real(8), Intent(out) :: ztilde, zinter, lambda0, gammae, ye, dztildedt9
  Real(8) :: ztot,ytot,bkt,abar,zbar,z2bar,zibar
  Real(8) :: etae_mb,sratio,efermkt,rel_ef,emass,efc,ae
  Real(8) :: defermktdt9,dsratiodefermkt
  Real(8) :: onethird=1./3.,twothird=2./3.

! Calculate Ye and other needed moments of the abundance distribution
  call y_moment(y,ztot,ytot,abar,zbar,z2bar,zibar)
  ye = zbar/abar

! Calculate electon distribution
  bkt=bok*t9
  emass=ele_en/clt**2
  etae_mb=log(rho*avn*ye*(2.0*pi*hbar**2/(emass*bkt))**1.5)
  rel_ef=hbar*(3.0*pi**2*rho*avn*ye)**onethird/(emass*clt)
  efermkt=ele_en*(sqrt(1+rel_ef**2)-1)/bkt
  efc=.5*hbar**2*(3.0*pi**2*rho*avn*ye)**twothird/(emass*bkt)
 !Write(lun_diag,'(a4,6es12.5)') 'MUb',bkt,etae_mb,efermkt,efc,rel_ef

! Calculate ratio f'/f for electrons (Salpeter, Eq. 24)
  call salpeter_ratio(efermkt,sratio,dsratiodefermkt)
  ztilde=sqrt(z2bar+zbar*sratio)
  If(itemp>0) Then
    defermktdt9=-efermkt/t9
    dztildedt9=0.5*zbar/ztilde * dsratiodefermkt*defermktdt9
  Else
    dztildedt9=0.0
  EndIf

! Calculate plasma quantities
  lambda0=sqrt(4*pi*rho*avn/abar)*(e2/bkt)**1.5 ! DGC, Eq. 3
  ae=(3./(4.*pi*avn*rho*ye))**onethird ! electron-sphere radius
  gammae=e2/(ae*bkt) ! electron Coulomb coupling parameter
  zinter=zibar/(ztilde**.58*zbar**.28)
  If(idiag>2) Write(lun_diag,'(a14,9es12.5)') 'Bahcall SCRN', t9, rho, ye, z2bar, zbar, sratio, ztilde,ztilde*lambda0, gammae

  Return
End Subroutine eos_interface

Subroutine salpeter_ratio(efmkt,ratio,dratiodefmkt)
!-----------------------------------------------------------------------------
! This routine calculates the Salpeter (1954) ratio f'/f(eta) needed for
! electron screening, using a fit to Figure 24 in that paper.
! efmkt is the ratio of electron chemical potential to kT.
!-----------------------------------------------------------------------------
  Use controls
  Real(8) :: efmkt,lefmkt,ratio,dratiodefmkt
  lefmkt=log10(efmkt)
  If(lefmkt<=-1.578347) Then ! Bahcall uses limit of -2, but this gives ratio slightly above 1.
    ratio=1.0
  Elseif(lefmkt>=1.5) Then
    ratio=0.0
  Else
    ratio=0.75793-(0.54621*lefmkt)-(0.30964*lefmkt**2)+(0.12535*lefmkt**3) &
&    +(0.1203*lefmkt**4)-(0.012857*lefmkt**5)-(0.014768*lefmkt**6)
  Endif

  If(itemp>0.and.lefmkt>1.578347.and.lefmkt<1.5) Then
    dratiodefmkt=(-0.54621-0.61928*lefmkt+0.37605*lefmkt**2+0.4812*lefmkt**3 &
&    -0.064285*lefmkt**4-0.088608*lefmkt**5)/(log(10.0)*efmkt)
  Else
    dratiodefmkt=0.0
  EndIf

  Return
End Subroutine salpeter_ratio

Subroutine y_moment(y,ztot,ytot,abar,zbar,z2bar,zibar)
!------------------------------------------------------------------------------
! This routine calculates moments of the abundance distribution for the EOS.
!------------------------------------------------------------------------------
  Use nuclear_data
  Use controls
  Real(8), Intent(in)  :: y(ny)
  Real(8), Intent(out) :: ztot,ytot,abar,zbar,z2bar,zibar
  Real(8)              :: atot

! Calculate abundance moments
  ytot =sum(y(:))
  atot =sum(aa*y)
  ztot =sum(zz*y)
  abar =atot/ytot
  zbar =ztot/ytot
  z2bar=sum(zz*zz*y)/ytot
  zibar=sum(zz**1.58*y)/ytot
  If(idiag>2) Write(lun_diag,'(a4,6es12.5)') 'YMom',ytot,abar,zbar,z2bar,zibar,ye

  Return
End Subroutine y_moment


module ort_lib
 use nan_lib
 interface ort1
  module procedure ort1_d
 end interface
 interface ort0
  module procedure ort0_d,ort0_z
 end interface
 interface orto
  module procedure orto_d,orto_z
 end interface

 logical,private,parameter :: loud=.false.

 !private :: ort0_d, orto_d
contains
 subroutine ort0_d(inp,out,mat)
  implicit none
  double precision,intent(inout) :: inp(:,:)
  double precision,intent(out),optional :: out(size(inp,1),size(inp,2))
  double precision,intent(out),optional :: mat(size(inp,2),size(inp,2))
  character(len=*),parameter  :: subnam='ort0_d'
  integer :: lwork,info,m,n,k,i,j
  double precision, allocatable :: work(:),tau(:)
  double precision,dimension(:,:),pointer :: y
  target :: inp,out
!-for check
!  double precision :: nrm,err
!  double precision,allocatable :: tmp(:,:),mnn(:,:)
!  double precision,external :: dnrm2
!-
  m=size(inp,1); n=size(inp,2); k=max(m,n)
  if(m.lt.n)then
   !write(*,*)subnam,': less rows than columns: ',shape(inp)
   if(present(mat))then
    forall(i=1:m,j=1:n)mat(i,j)=inp(i,j)
    forall(i=m+1:n,j=1:n)mat(i,j)=0.d0
   end if
   if(present(out))then
    forall(i=1:m,j=1:n)out(i,j)=0.d0
    forall(i=1:m)out(i,i)=1.d0
   else
    forall(i=1:m,j=1:n)inp(i,j)=0.d0
    forall(i=1:m)inp(i,i)=1.d0
   end if
   return
  end if
!-for check-
!  allocate(tmp(m,n), mnn(n,n))
!  call dcopy(m*n,inp,1,tmp,1); nrm=dnrm2(m*n,inp,1)
!-
  lwork=64*k
  allocate(tau(k),work(lwork),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  if(present(out))then;y=>out;call dcopy(m*n,inp,1,out,1);else;y=>inp;endif

  call dgeqrf(m,n,y,m,tau,work,lwork,info)
  if(info.ne.0)then; write(*,*) subnam,': dgeqrf info: ',info; stop; endif
  if(nan(y))then;write(*,*)subnam,': dgeqrf returns NaNs, are you using Intel MKL 2011?';stop;endif

  if(present(mat))then
   forall(j=1:n)
    forall(i=1:j)   mat(i,j)=y(i,j)
    forall(i=j+1:n) mat(i,j)=0.d0
   end forall
  end if
!-for check
!   forall(j=1:n)
!    forall(i=1:j)   mnn(i,j)=y(i,j)
!    forall(i=j+1:n) mnn(i,j)=0.d0
!   end forall
!-
  call dorgqr(m,n,n,y,m,tau,work,lwork,info)
  if(info.ne.0)then; write(*,*) subnam,': dorgqr info: ',info; stop; end if
!-check-
!  call dgemm('n','n',m,n,n,-1.d0,y,m,mnn,n,1.d0,tmp,m)
!  err=dnrm2(m*n,tmp,1)
!  write(*,*)subnam,': err: ',err/nrm
!-
  nullify(y)
  deallocate(tau,work)
 end subroutine

 subroutine ort0_z(inp,out,mat)
  implicit none
  double complex,intent(inout) :: inp(:,:)
  double complex,intent(out),optional :: out(size(inp,1),size(inp,2))
  double complex,intent(out),optional :: mat(size(inp,2),size(inp,2))
  character(len=*),parameter  :: subnam='ort0_z'
  double complex,parameter :: zero=(0.d0,0.d0),one=(1.d0,0.d0)
  integer :: lwork,info,m,n,k,i,j
  double complex, allocatable :: work(:),tau(:)
  double complex,dimension(:,:),pointer :: y
  target :: inp,out
!-for check
!  double precision :: nrm,err
!  double precision,allocatable :: tmp(:,:),mnn(:,:)
!  double precision,external :: dnrm2
!-
  m=size(inp,1); n=size(inp,2); k=max(m,n)
  if(m.lt.n)then
   !write(*,*)subnam,': less rows than columns: ',shape(inp)
   if(present(mat))then
    forall(i=1:m,j=1:n)mat(i,j)=inp(i,j)
    forall(i=m+1:n,j=1:n)mat(i,j)=zero
   end if
   if(present(out))then
    forall(i=1:m,j=1:n)out(i,j)=zero
    forall(i=1:m)out(i,i)=one
   else
    forall(i=1:m,j=1:n)inp(i,j)=zero
    forall(i=1:m)inp(i,i)=one
   end if
   return
  end if
!-for check-
!  allocate(tmp(m,n), mnn(n,n))
!  call dcopy(m*n,inp,1,tmp,1); nrm=dnrm2(m*n,inp,1)
!-
  lwork=64*k
  allocate(tau(k),work(lwork),stat=info)
  if(info.ne.0)then;write(*,*)subnam,': cannot allocate';stop;endif
  if(present(out))then;y=>out;call zcopy(m*n,inp,1,out,1);else;y=>inp;end if

  call zgeqrf(m,n,y,m,tau,work,lwork,info)
  if(info.ne.0)then; write(*,*) subnam,': zgeqrf info: ',info; stop; end if
  if(nan(y))then;write(*,*)subnam,': zgeqrf returns NaNs, are you using Intel MKL 2011?';stop;endif

  if(present(mat))then
   forall(j=1:n)
    forall(i=1:j)   mat(i,j)=y(i,j)
    forall(i=j+1:n) mat(i,j)=(0.d0,0.d0)
   end forall
  end if

!-for check
!   forall(j=1:n)
!    forall(i=1:j)   mnn(i,j)=y(i,j)
!    forall(i=j+1:n) mnn(i,j)=0.d0
!   end forall
!-
  call zungqr(m,n,n,y,m,tau,work,lwork,info)
  if(info.ne.0)then; write(*,*) subnam,': zungqr info: ',info; stop; end if
!-check-
!  call dgemm('n','n',m,n,n,-1.d0,y,m,mnn,n,1.d0,tmp,m)
!  err=dnrm2(m*n,tmp,1)
!  write(*,*)subnam,': err: ',err/nrm
!-
  nullify(y)
  deallocate(tau,work)
 end subroutine

 subroutine ort1_d(u,v,y,b)
  implicit none
  double precision,intent(in) :: u(:,:)
  double precision,intent(inout) :: v(:)
  double precision,intent(out),optional :: y(size(v))
  double precision,intent(out),optional :: b(size(u,2)+1)
  character(len=*),parameter :: subnam='ort1_d'
  integer :: nu,nv,n,r,pass
  double precision,allocatable :: g(:),btmp(:)
  double precision,pointer :: bb(:),yy(:)
  double precision :: nrm1,nrm2
  logical :: reort
  double precision,external :: dnrm2
  target :: v,y,b,btmp

  r=size(u,2); nu=size(u,1); nv=size(v)
  if(nu.ne.nv)then
   write(*,*)subnam,': size mismatch: u[',nu,r,'] v[',nv,']'
   stop
  end if
  n=nu
  if(present(y))then
   yy=>y; y=v
  else
   yy=>v
  end if
  if(r.ge.n)then
   !write(*,'(2a,2i10)')subnam,': warning: n,r: ',n,r
   if(present(b))then
    call dgemv('t',n,n,1.d0,u,n,v,1, 0.d0,b(1:n),1)
    b(n+1:r+1)=0.d0
   end if
   yy=0.d0
   return
  end if
  if(r.eq.0)then
   nrm2=dnrm2(n,v,1)
   if(nrm2.le.0.d0)then
    if(loud)write(*,'(2a,e10.3)')subnam,': small norm: ',nrm2
    yy=0.d0
   else
    yy=yy/nrm2
   end if
   if(present(b))b(1)=nrm2
   !write(*,*)subnam,': return since r=0'
   return
  end if

  if(present(b))then
   bb=>b
  else
   allocate(btmp(r+1)); bb=>btmp
  end if
  allocate(g(r))

  nrm1=dnrm2(n,yy,1)
  call dgemv('t',n,r,1.d0,u,n,yy,1, 0.d0,bb,1)
  call dgemv('n',n,r,-1.d0,u,n,bb,1, 1.d0,yy,1)
  nrm2=dnrm2(n,yy,1); reort=nrm2.lt.nrm1/2; pass=0

  do while(reort.and.pass.lt.3)
   call dgemv('t',n,r,1.d0,u,n,yy,1, 0.d0,g,1)
   call dgemv('n',n,r,-1.d0,u,n,g,1, 1.d0,yy,1)
   bb(1:r)=bb(1:r)+g
   nrm1=nrm2; nrm2=dnrm2(n,yy,1); reort=nrm2.lt.nrm1/2; pass=pass+1
  end do
  if(nrm2.lt.1.d-15)then
   if(loud)write(*,*)subnam,': small norm: ',nrm2
   yy=0.d0; bb(r+1)=0.d0
  else
   yy=yy/nrm2; bb(r+1)=nrm2
  end if

  nullify(bb,yy)
  deallocate(g)
  if(allocated(btmp))deallocate(btmp)
 end subroutine

 subroutine orto_d(u,v,out,mat)
  implicit none
  double precision,intent(in) :: u(:,:)
  double precision,intent(inout) :: v(:,:)
  double precision,intent(out),optional :: out(size(v,1),size(v,2))
  double precision,intent(out),optional :: mat(size(u,2)+size(v,2),size(v,2))
  character(len=*),parameter :: subnam='orto_d'
  integer :: ru,rv,nu,nv,n,j, r,pass
  double precision,allocatable :: x(:),gu(:),gv(:),btmp(:,:)
  double precision,pointer :: bb(:,:),yy(:,:)
  double precision :: nrm1,nrm2
  logical :: reort
  double precision,external :: dnrm2
  target :: v,out,mat,btmp

  !write(*,'(a,2(a,2i5),a)')subnam,': u[',size(u),'] v[',size(v),']'
  ru=size(u,2); rv=size(v,2); nu=size(u,1); nv=size(v,1)
  if(nu.ne.nv)then
   write(*,*)subnam,': size mismatch: u[',nu,ru,'] v[',nv,rv,']'
   stop
  end if
  n=nu
  if(present(out))then
   yy=>out; out=v
  else
   yy=>v
  end if
  if(present(mat))then
   bb=>mat
  else
   allocate(btmp(ru+rv,rv)); bb=>btmp
  end if
  allocate(x(n),gu(ru),gv(rv))

  do j=1,rv
   r=j-1
   x=v(:,j); nrm1=dnrm2(n,x,1)
   call dgemv('t',n,ru,1.d0,u,n,x,1, 0.d0,gu,1)
   call dgemv('t',n,r,1.d0,yy,n,x,1, 0.d0,gv,1)
   call dgemv('n',n,ru,-1.d0,u,n,gu,1, 1.d0,x,1)
   call dgemv('n',n,r,-1.d0,yy,n,gv,1, 1.d0,x,1)
   bb(1:ru,j)=gu; bb(ru+1:ru+r,j)=gv(1:r)
   nrm2=dnrm2(n,x,1); reort=nrm2.lt.nrm1/2; pass=0

   do while(reort.and.pass.lt.3)
    call dgemv('t',n,ru,1.d0,u,n,x,1, 0.d0,gu,1)
    call dgemv('t',n,r,1.d0,yy,n,x,1, 0.d0,gv,1)
    call dgemv('n',n,ru,-1.d0,u,n,gu,1, 1.d0,x,1)
    call dgemv('n',n,r,-1.d0,yy,n,gv,1, 1.d0,x,1)
    bb(1:ru,j)=bb(1:ru,j)+gu; bb(ru+1:ru+r,j)=bb(ru+1:ru+r,j)+gv(1:r)
    nrm1=nrm2; nrm2=dnrm2(n,x,1); reort=nrm2.lt.nrm1/2; pass=pass+1
   end do
   if(nrm2.lt.1.d-15)then
    if(loud)write(*,*)subnam,': small norm: ',nrm2
    yy(:,j)=0.d0; bb(ru+j,j)=0.d0
   else
    yy(:,j)=x/nrm2; bb(ru+j,j)=nrm2
   end if
   bb(ru+j+1:ru+rv,j)=0.d0
  end do

  nullify(bb,yy)
  deallocate(x,gu,gv)
  if(allocated(btmp))deallocate(btmp)
 end subroutine
 subroutine orto_z(u,v,out,mat)
  implicit none
  double complex,intent(in) :: u(:,:)
  double complex,intent(inout) :: v(:,:)
  double complex,intent(out),optional :: out(size(v,1),size(v,2))
  double complex,intent(out),optional :: mat(size(u,2)+size(v,2),size(v,2))
  character(len=*),parameter :: subnam='orto_d'
  double complex,parameter :: zero=(0.d0,0.d0),one=(1.d0,0.d0)
  integer :: ru,rv,nu,nv,n,j, r,pass
  double complex,allocatable :: x(:),gu(:),gv(:),btmp(:,:)
  double complex,pointer :: bb(:,:),yy(:,:)
  double precision :: nrm1,nrm2
  logical :: reort
  double precision,external :: dznrm2
  target :: v,out,mat,btmp

  !write(*,'(a,2(a,2i5),a)')subnam,': u[',size(u),'] v[',size(v),']'
  ru=size(u,2); rv=size(v,2); nu=size(u,1); nv=size(v,1)
  if(nu.ne.nv)then
   write(*,*)subnam,': size mismatch: u[',nu,ru,'] v[',nv,rv,']'
   stop
  end if
  n=nu
  if(present(out))then
   yy=>out; out=v
  else
   yy=>v
  end if
  if(present(mat))then
   bb=>mat
  else
   allocate(btmp(ru+rv,rv)); bb=>btmp
  end if
  allocate(x(n),gu(ru),gv(rv))

  do j=1,rv
   r=j-1
   x=v(:,j); nrm1=dznrm2(n,x,1)
   call zgemv('c',n,ru,one,u,n,x,1, zero,gu,1)
   call zgemv('c',n,r,one,yy,n,x,1, zero,gv,1)
   call zgemv('n',n,ru,-one,u,n,gu,1, one,x,1)
   call zgemv('n',n,r,-one,yy,n,gv,1, one,x,1)
   bb(1:ru,j)=gu; bb(ru+1:ru+r,j)=gv(1:r)
   nrm2=dznrm2(n,x,1); reort=nrm2.lt.nrm1/2; pass=0

   do while(reort.and.pass.lt.3)
    call zgemv('c',n,ru,one,u,n,x,1, zero,gu,1)
    call zgemv('c',n,r,one,yy,n,x,1, zero,gv,1)
    call dgemv('n',n,ru,-one,u,n,gu,1, one,x,1)
    call dgemv('n',n,r,-one,yy,n,gv,1, one,x,1)
    bb(1:ru,j)=bb(1:ru,j)+gu; bb(ru+1:ru+r,j)=bb(ru+1:ru+r,j)+gv(1:r)
    nrm1=nrm2; nrm2=dznrm2(n,x,1); reort=nrm2.lt.nrm1/2; pass=pass+1
   end do
   if(nrm2.lt.1.d-15)then
    if(loud)write(*,*)subnam,': small norm: ',nrm2
    yy(:,j)=zero; bb(ru+j,j)=zero
   else
    yy(:,j)=x/nrm2; bb(ru+j,j)=nrm2
   end if
   bb(ru+j+1:ru+rv,j)=zero
  end do

  nullify(bb,yy)
  deallocate(x,gu,gv)
  if(allocated(btmp))deallocate(btmp)
 end subroutine
end module


       function dyadic_11(T1, T2)
        implicit none

        type(Tensor1), intent(in) :: T1, T2
        type(Tensor2) :: dyadic_11
        integer i, j

        forall(i=1:3,j=1:3) dyadic_11%ab(i,j) = T1%a(i) * T2%a(j)

       end function dyadic_11

       function dyadic_22(T1, T2)
        implicit none

        type(Tensor2), intent(in) :: T1, T2
        type(Tensor4) :: dyadic_22
        integer i, j, k, l

        forall(i=1:3,j=1:3,k=1:3,l=1:3) dyadic_22%abcd(i,j,k,l)
     *                                = T1%ab(i,j) * T2%ab(k,l)

       end function dyadic_22

       function dyadic_2s2s(T1, T2)
        implicit none

        type(Tensor2s), intent(in) :: T1, T2
        type(Tensor4s) :: dyadic_2s2s
        integer i, j

        forall(i=1:6,j=1:6) dyadic_2s2s%a6b6(i,j) = T1%a6(i) * T2%a6(j)

       end function dyadic_2s2s


      SUBROUTINE T2D( BUFIN, NSAMPS, ST, SIT, BUFOUT, MSAMPS, SD, SID,
     &  SCRBUF, AVEVEL)
C     T2D CONVERTS A TIME TRACE (BUFIN) INTO A DEPTH TRACE (BUFOUT) USING
C  AVERAGE VELOCITIES (AVEVEL). THE TIMES ARE ONE WAY TRAVEL TIMES.
C  T2D EXPECTS A VELOCITY ARRAY IN A CONSTANT TIME INCREMENT (A VELOCITY FOR
C  EVERY SAMPLE).
C     T2D APPLIES A VELOCITY TRANSFORMATION TO A TIME DOMAIN TRACE TO GET
C  A DEPTH DOMAIN TRACE.  THE OUTPUT TRACE IS AT A UNIFORM SAMPLE INTERVAL, SO
C  IT IS READY TO BE PLOTTED IN THE NORMAL MANNER.
C  ARGUMENTS:
C   BUFIN  - AN ARRAY OF DATA TO BE MOVED (TRANSFORMED).  A TIME DOMAIN TRACE.
C   NSAMPS - THE INTEGER NUMBER OF SAMPLES IN ARRAY BUFIN.  THE LENGTH OF THE
C            THE INPUT DATA.
C   ST     - THE START TIME OF BUFIN.  THE TIME IN SECONDS ASSOCIATED WITH THE
C            SAMPLE BUFIN(1).
C   SIT    - SAMPLE INTERVAL IN TIME.  THE TIME UNITS, IN SECONDS, BETWEEN
C            SUCCESSIVE SAMPLES IN BUFIN.
C   BUFOUT - AN ARRAY TO RECEIVED THE TRANSFORMED TRACE.  THE DEPTH DOMAIN TRACE
C            THE OUTPUT ARRAY.  MUST BE DIFFERENT FROM BUFIN.
C   MSAMPS - THE NUMBER OF OUTPUT SAMPLES.  T2D WILL ONLY STORE MSAMPS SAMPLES
C            IN THE OUTPUT ARRAY.
C   SD     - START DEPTH.  THE DEPTH OF THE FIRST OUTPUT SAMPLE (BUFOUT(1)).
C   SID    - SAMPLE INTERVAL IN THE DEPTH DOMAIN.  THE  DISTANCE BETWEEN
C            SUCCESSIVE OUTPUT SAMPLES.
C   SCRBUF - A SCRATCH ARRAY OF LENGTH NSAMPS.
C   AVEVEL - AN ARRAY OF AVERAGE VELOCITIES ASSOCIATED WITH EACH SAMPLE (OR TIME
C            OF BUFIN.)  AVEVEL MUST BE NSAMPS LONG - ONE VELOCITY FOR EVERY TIME
C            SAMPLE.  THESE ARE ONE WAY TRAVEL TIMES!!!!
C
C      PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, APRIL 1979
C
      DIMENSION BUFIN(1),BUFOUT(1),SCRBUF(1),AVEVEL(1)
      INTEGER LINC, LTEMP, sd
C
C    CALCULATE A DEPTH FOR EVERY TIME SAMPLE.  ROUND THE DEPTH TO THE
C    NEAREST DEPTH SAMPLE INTERVAL BY ADDING HALF THE INTERVAL BEFORE
C    TRUNCATING BY MAKING IT INTO AN INTEGER.  DIVIDING THE INTEGER DEPTH
C    BY THE INTEGER SAMPLE INTERVAL AND THEN MULTIPLYING BY THE SAMPLE
C    INTERVAL THEN ASSURES THAT THE RESULTANT DEPTH IS A MULTIPLE OF THE
C    SAMPLE INTERVAL.
C
c   mod 13 Oct 08 - do depth as real number
c
      sdepth = REAL(sd)
      LINC=SID                                                          ! MAKE THE SAMPLE INTERVAL AN INTEGER
      SID2=SID/2.
c****
c****  fill scrbuf with the depth of every output sample
c****
      DO 10 I = 1, NSAMPS
         TIME = ST+SIT*FLOAT(I-1)
c         LTEMP = TIME*AVEVEL(I)+SID2
c         LTEMP = (LTEMP/LINC)*LINC
         ltemp = NINT( TIME*AVEVEL(I) )
c         SCRBUF(I) = LTEMP
          scrbuf(i) = time * avevel(i)
   10 CONTINUE
C
C    FIND THE CLOSEST DEPTH IN THE CONVERTED DEPTH ARRAY FOR EVERY
C    OUTPUT DEPTH SAMPLE.  THE OUTPUT DEPTH ARRAY IS A UNIFORMLY SAMPLED
C    ARRAY BUT THE CONVERTED (TIME) ARRAY IS NOT.  USE WHATEVER CONVERTED
C    ARRAY POINT THAT IS CLOSEST, THUS ALLOWING THE SAME POINT TO APPEAR
C    IN THE OUTPUT ARRAY OR SKIPPING SOME.
C
      INDXT=1                                                           ! THE INDEX TO THE CONVERTED TIME ARRAY
      INDXD=0                                                           ! THE INDEX TO THE OUTPUT DEPTH ARRAY
C
  110 INDXD=INDXD+1
      IF(INDXD.GT.MSAMPS) RETURN
      DEPTH = sdepth + (INDXD-1) * SID                                  ! CALCULATE THE NEXT DEPTH VALUE
  120 CONTINUE
      IF(DEPTH.GE.SCRBUF(INDXT)) GO TO 200
      IF(DEPTH.GE.SCRBUF(INDXT-1)) GO TO 130
c**** the depth wanted is before the one we're at, so back up
      INDXT=INDXT-1
      IF(INDXT.GT.0) GO TO 120
      BUFOUT(INDXD)=0.                                                  ! THE OUTPUT IS BEFORE THE INPUT!
      INDXT=1
      GO TO 110
c****
c**** the depth is between this one and the prior one, use the prior one
  130 BUFOUT(INDXD)=BUFIN(INDXT-1)
      GO TO 110
c****
c****  if the depth is after this one, go to the next one
  200 IF(DEPTH.GT.SCRBUF(INDXT)) GO TO 300
c***
c***  the depth is the same as this one, use it!
      BUFOUT(INDXD)=BUFIN(INDXT)
      GO TO 110
c****
c****  set up to try the next sample
  300 INDXT=INDXT+1
      IF(INDXT.LE.NSAMPS) GO TO 120
      DO 310 I=INDXD,MSAMPS
  310 BUFOUT(I)=0.
      RETURN
      END


	SUBROUTINE VI_POOL  ( ilvo, lt, lb,
     +                        ovctop, ovcbtm, sfcval,
     +                        rlnpi, rlnpo, valu, pln, iret )
C************************************************************************
C* VI_POOL								*
C*									*
C* This subroutine computes ln (p) on an output level and stores it	*
C* in the internal array.						*
C*									*
C* VI_POOL ( ILVO, LT, LB, OVCTOP, OVCBTM, SFCVAL, RLNPI, RLNPO,        *
C*           VALU, PLN, IRET )                                          *
C*									*
C* Input parameters:							*
C*	ILVO		INTEGER		Output level # 			*
C*	LT		INTEGER		Top level index			*
C*	LB		INTEGER		Bottom level index		*
C*	OVCTOP		REAL(*) 	upper vc values	                *
C*	OVCBTM		REAL(*) 	lower vc values	                *
C*
C* Input/Ouput parameters:                                              *
C*      SFCVAL(kxky,np) REAL            surface value of parms          *
C*      RLNPI(kxky,nli) REAL            Ln (p) on input lvls            *
C*      RLNPO(kxky,nlo) REAL            ln (p) on output lvls           *
C*      VALU (kxky,nli) REAL            values on input lvls            *
C*	PLN(kxky)       REAL            previously local array          *
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC		06/92						*
C* K. Brill/NMC		07/92	Added p on z above ground		*
C* R. Miller/COMET   	06/94   Changed 100000 to 10000 for eta sgma    *
C* G. Hull/SAIC         03/08   Changed ovcbuf indxs to ovctop, ovcbtm  *
C************************************************************************
	INCLUDE		'vicmn.cmn'

	REAL		ovctop (kxky), ovcbtm (kxky)
	REAL		sfcval(kxky,np)
	REAL            rlnpi (kxky,nli), rlnpo (kxky,nlo)
	REAL		valu (kxky,nli), pln (kxky)
C*
	LOGICAL		exist
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
	exist = .false.
C
C*	Load output array with missing values.
C
	DO ij = 1, kxky
	    pln (ij) = RMISSD
	END DO
C*
	rlvo = levout ( ilvo )
C
C*	Check the output vertical coordinate and compute it.
C
	IF ( vcordo .eq. NPRES ) THEN
	    exist = .true.
	    DO ij = 1, kxky
		pln (ij) = rlvo
	    END DO
	ELSE IF ( vcordo .eq. NHGHT ) THEN
	    exist = .true.
	    CALL VC_PONZ ( rlvo, ovctop, ovcbtm,
     +                     valu (1,lt), valu (1,lb),
     +                     rlnpi (1,lt), rlnpi (1,lb),
     +                     kxky, pln, iret )
C*
	ELSE IF ( vcordo .eq. NTHTA ) THEN
	    exist = .true.
	    CALL VC_PONT ( rlvo, ovctop, ovcbtm,
     +                     valu (1,lt), valu (1,lb),
     +                     rlnpi (1,lt), rlnpi (1,lb),
     +			   kxky, pln, iret )
C*
	ELSE IF ( vcordo .eq. NSGMA ) THEN
	    IF ( lpmrds (1) ) THEN
	        exist = .true.
		rlevo = rlvo / 10000.
	    	CALL VC_PFSG ( rlevo, sfcval, ptopo, kxky,
     +			       pln, iret )
	    END IF
C*
	ELSE IF ( vcordo .eq. NETA ) THEN
	    IF ( lpmrds (1) .and. lpmrds (3) ) THEN
		exist = .true.
		rlevo = rlvo / 10000.
		CALL VC_PFET ( rlevo, sfcval,
     +                         sfcval( 1,3 ),
     +                         ptopo, kxky, pln, iret )
	    END IF
C*
	ELSE IF ( vcordo .eq. NZAGL .and. lpmrds (3) ) THEN
	    exist = .true.
C
C*	    VC_PONZ can be used here because it computes only dz
C*	    which means that the offset surface value subtracts out.
C
	    CALL VC_PONZ ( rlvo, ovctop, ovcbtm,
     +                     valu (1,lt), valu (1,lb),
     +                     rlnpi (1,lt), rlnpi (1,lb),
     +                     kxky, pln, iret )
C*
	END IF

C*
	IF ( .not. exist .or. iret .ne. 0 ) THEN
	    iret = +2
	ELSE
C
C*	    Load the ln (p) array.
C
	    DO ij = 1, kxky
	    	IF ( .not. ERMISS ( pln (ij) ) ) THEN
     		    rlnpo (ij,ilvo ) = ALOG ( pln (ij) )
		    IF ( lpmrds (1) .and. rlnpo (ij,ilvo) .ge.
     +			 rlnpi (ij,1) ) THEN
			rlnpo (ij,ilvo) = RMISSD
		    END IF
		END IF
	    END DO
	END IF
C*
	RETURN
	END


PROGRAM mcik01

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       =============================================================
!       Purpose: This program computes the modified Bessel functions
!                I0(z), I1(z), K0(z), K1(z), and their derivatives
!                for a complex argument using subroutine CIK01
!       Input :  z --- Complex argument
!       Output:  CBI0 --- I0(z)
!                CDI0 --- I0'(z)
!                CBI1 --- I1(z)
!                CDI1 --- I1'(z)
!                CBK0 --- K0(z)
!                CDK0 --- K0'(z)
!                CBK1 --- K1(z)
!                CDK1 --- K1'(z)
!       Example: z = 20.0 + i 10.0

!     n      Re[In(z)]      Im[In(z)]      Re[In'(z)]     Im[In'(z)]
!    -----------------------------------------------------------------
!     0   -.38773811D+08 -.13750292D+08 -.37852037D+08 -.13869150D+08
!     1   -.37852037D+08 -.13869150D+08 -.36982347D+08 -.13952566D+08

!     n      Re[Kn(z)]      Im[Kn(z)]      Re[Kn'(z)]     Im[Kn'(z)]
!    -----------------------------------------------------------------
!     0   -.37692389D-09  .39171613D-09  .38056380D-09 -.40319029D-09
!     1   -.38056380D-09  .40319029D-09  .38408264D-09 -.41545502D-09
!       =============================================================

IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)
WRITE(*,*)'  Please enter x and y (z=x+iy) '
!        READ(*,*)X,Y
x=20.0
y=10.0
z=CMPLX(x,y)
WRITE(*,30)x,y
CALL cik01(z,cbi0,cdi0,cbi1,cdi1,cbk0,cdk0,cbk1,cdk1)
WRITE(*,*)
WRITE(*,*)'  n      Re[In(z)]      Im[In(z)]',  &
    '      Re[In''(Z)]     IM[IN''(Z)]'
WRITE(*,*)' -------------------------------',  &
    '----------------------------------'
WRITE(*,10)cbi0,cdi0
WRITE(*,20)cbi1,cdi1
WRITE(*,*)
WRITE(*,*)'  n      Re[Kn(z)]      Im[Kn(z)]',  &
    '      Re[Kn''(Z)]     IM[KN''(Z)]'
WRITE(*,*)' -------------------------------',  &
    '----------------------------------'
WRITE(*,10)cbk0,cdk0
WRITE(*,20)cbk1,cdk1
10      FORMAT(3X,'0',2X,4D15.7)
20      FORMAT(3X,'1',2X,4D15.7)
30      FORMAT(3X,3HZ =,f7.2,' + i',f7.2)
END PROGRAM mcik01

SUBROUTINE cik01(z,cbi0,cdi0,cbi1,cdi1,cbk0,cdk0,cbk1,cdk1)

!       ==========================================================
!       Purpose: Compute modified Bessel functions I0(z), I1(z),
!                K0(z), K1(z), and their derivatives for a
!                complex argument
!       Input :  z --- Complex argument
!       Output:  CBI0 --- I0(z)
!                CDI0 --- I0'(z)
!                CBI1 --- I1(z)
!                CDI1 --- I1'(z)
!                CBK0 --- K0(z)
!                CDK0 --- K0'(z)
!                CBK1 --- K1(z)
!                CDK1 --- K1'(z)
!       ==========================================================

COMPLEX, INTENT(IN)                      :: z
COMPLEX, INTENT(OUT)                     :: cbi0
COMPLEX, INTENT(OUT)                     :: cdi0
COMPLEX, INTENT(OUT)                     :: cbi1
COMPLEX, INTENT(OUT)                     :: cdi1
COMPLEX, INTENT(OUT)                     :: cbk0
COMPLEX, INTENT(OUT)                     :: cdk0
COMPLEX, INTENT(OUT)                     :: cbk1
COMPLEX, INTENT(OUT)                     :: cdk1
IMPLICIT DOUBLE PRECISION (a,b,d-h,o-y)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION a(12),b(12),a1(10)

pi=3.141592653589793D0
ci=(0.0D0,1.0D0)
a0=CDABS(z)
z2=z*z
z1=z
IF (a0 == 0.0D0) THEN
  cbi0=(1.0D0,0.0D0)
  cbi1=(0.0D0,0.0D0)
  cdi0=(0.0D0,0.0D0)
  cdi1=(0.5D0,0.0D0)
  cbk0=(1.0D+300,0.0D0)
  cbk1=(1.0D+300,0.0D0)
  cdk0=-(1.0D+300,0.0D0)
  cdk1=-(1.0D+300,0.0D0)
  RETURN
END IF
IF (REAL(z) < 0.0) z1=-z
IF (a0 <= 18.0) THEN
  cbi0=(1.0D0,0.0D0)
  cr=(1.0D0,0.0D0)
  DO  k=1,50
    cr=0.25D0*cr*z2/(k*k)
    cbi0=cbi0+cr
    IF (CDABS(cr/cbi0) < 1.0D-15) EXIT
  END DO
  15         cbi1=(1.0D0,0.0D0)
  cr=(1.0D0,0.0D0)
  DO  k=1,50
    cr=0.25D0*cr*z2/(k*(k+1))
    cbi1=cbi1+cr
    IF (CDABS(cr/cbi1) < 1.0D-15) EXIT
  END DO
  25         cbi1=0.5D0*z1*cbi1
ELSE
  DATA a/0.125D0,7.03125D-2, 7.32421875D-2,1.1215209960938D-1,  &
      2.2710800170898D-1,5.7250142097473D-1,  &
      1.7277275025845D0,6.0740420012735D0,  &
      2.4380529699556D01,1.1001714026925D02,  &
      5.5133589612202D02,3.0380905109224D03/
  DATA b/-0.375D0,-1.171875D-1, -1.025390625D-1,-1.4419555664063D-1,  &
      -2.7757644653320D-1,-6.7659258842468D-1,  &
      -1.9935317337513D0,-6.8839142681099D0,  &
      -2.7248827311269D01,-1.2159789187654D02,  &
      -6.0384407670507D02,-3.3022722944809D03/
  k0=12
  IF (a0 >= 35.0) k0=9
  IF (a0 >= 50.0) k0=7
  ca=CDEXP(z1)/CDSQRT(2.0D0*pi*z1)
  cbi0=(1.0D0,0.0D0)
  zr=1.0D0/z1
  DO  k=1,k0
    cbi0=cbi0+a(k)*zr**k
  END DO
  cbi0=ca*cbi0
  cbi1=(1.0D0,0.0D0)
  DO  k=1,k0
    cbi1=cbi1+b(k)*zr**k
  END DO
  cbi1=ca*cbi1
END IF
IF (a0 <= 9.0) THEN
  cs=(0.0D0,0.0D0)
  ct=-CDLOG(0.5D0*z1)-0.5772156649015329D0
  w0=0.0D0
  cr=(1.0D0,0.0D0)
  DO  k=1,50
    w0=w0+1.0D0/k
    cr=0.25D0*cr/(k*k)*z2
    cs=cs+cr*(w0+ct)
    IF (CDABS((cs-cw)/cs) < 1.0D-15) GO TO 45
    cw=cs
  END DO
  45         cbk0=ct+cs
ELSE
  DATA a1/0.125D0,0.2109375D0, 1.0986328125D0,1.1775970458984D01,  &
      2.1461706161499D02,5.9511522710323D03,  &
      2.3347645606175D05,1.2312234987631D07, 8.401390346421D08,7.2031420482627D10/
  cb=0.5D0/z1
  zr2=1.0D0/z2
  cbk0=(1.0D0,0.0D0)
  DO  k=1,10
    cbk0=cbk0+a1(k)*zr2**k
  END DO
  cbk0=cb*cbk0/cbi0
END IF
cbk1=(1.0D0/z1-cbi1*cbk0)/cbi0
IF (REAL(z) < 0.0) THEN
  IF (DIMAG(z) < 0.0) cbk0=cbk0+ci*pi*cbi0
  IF (DIMAG(z) > 0.0) cbk0=cbk0-ci*pi*cbi0
  IF (DIMAG(z) < 0.0) cbk1=-cbk1+ci*pi*cbi1
  IF (DIMAG(z) > 0.0) cbk1=-cbk1-ci*pi*cbi1
  cbi1=-cbi1
END IF
cdi0=cbi1
cdi1=cbi0-1.0D0/z*cbi1
cdk0=-cbk1
cdk1=-cbk0-1.0D0/z*cbk1
RETURN
END SUBROUTINE cik01


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM          VA15MA
C
C  VA15 test driver for problems derived from SIF files.
C
C  Nick Gould, for CGT Productions.
C  October 1993.
C  Modified by Ph. Toint.
C
      INTEGER          NMAX  , IOUT  , N , M , INPUT , MSAVE
      INTEGER          LP    , MP    , INFO  , LW, I , MAXIT
      INTEGER          IFLAG , ICALL , INSPEC, IPRINT( 2 )
CS    REAL             F, EPS, GTOL  , GNORM , BIGINF, ZERO
CD    DOUBLE PRECISION F, EPS, GTOL  , GNORM , BIGINF, ZERO
      LOGICAL          DIAGCO, BOUNDS
CBIG  PARAMETER      ( NMAX = 100000 )
CMED  PARAMETER      ( NMAX =  10000 )
CTOY  PARAMETER      ( NMAX =   1000 )
CCUS  PARAMETER      ( NMAX =  50000 )
      PARAMETER      ( IOUT  = 6, MSAVE = 7 )
      PARAMETER      ( LW    = NMAX * ( 2 * MSAVE + 1 ) + 2 * MSAVE )
      PARAMETER      ( INPUT = 55, INSPEC = 56 )
CS    PARAMETER      ( BIGINF = 9.0E+19, ZERO = 0.0E0 )
CD    PARAMETER      ( BIGINF = 9.0D+19, ZERO = 0.0D0 )
CS    REAL             X     ( NMAX ), G     ( NMAX )
CS    REAL             DIAG  ( NMAX ), W     ( LW   )
CD    DOUBLE PRECISION X     ( NMAX ), G     ( NMAX )
CD    DOUBLE PRECISION DIAG  ( NMAX ), W     ( LW   )
      CHARACTER * 10   XNAMES( NMAX ), PNAME, SPCDAT
      INTRINSIC        ABS   , MAX
CS    EXTERNAL         VA15C
CD    EXTERNAL         VA15CD
CS    COMMON         / VA15D  / GTOL , MP, LP, INFO
CD    COMMON         / VA15DD / GTOL , MP, LP, INFO
      REAL             CPU( 2 ), CALLS( 4 )
C
C  Open the Spec file for the method.
C
      SPCDAT = 'VA15.SPC'
      OPEN ( INSPEC, FILE = SPCDAT, FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INSPEC
C
C
C  Read input Spec data.
C
C     M        : the number of iterations in the memory
C     IPRINT(1): specifies the frequency of output
C     IPRINT(2): specifies the amount of output
C     MAXIT    : the maximum number of iterations,
C     EPS      : the stopping tolerance
C
      READ ( INSPEC, 1000 ) M, IPRINT( 1 ), IPRINT( 2 ), MAXIT,
     *                      EPS
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
      REWIND INPUT
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, W, W( NMAX + 1 ), NMAX )
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
      BOUNDS  = .FALSE.
      DO 10 I = 1, N
         IF ( W( I ) .GT. - BIGINF .OR. W( NMAX + I ) .LT. BIGINF )
     *      BOUNDS = .TRUE.
   10 CONTINUE
      IF ( BOUNDS ) WRITE( IOUT, 2030 )
      LP     = IOUT
      MP     = IOUT
      ICALL  = 0
      IFLAG  = 0
      DIAGCO = .FALSE.
   20 CONTINUE
C
C  Evaluate the function and gradient.
C
      CALL UOFG( N, X, F, G, .TRUE. )
C
C  Call the optimizer.
C
CS    CALL VA15A ( N, M, X, F, G, DIAGCO, DIAG, IPRINT, EPS, W, IFLAG )
CD    CALL VA15AD( N, M, X, F, G, DIAGCO, DIAG, IPRINT, EPS, W, IFLAG )
C
C  Check exit conditions and prepare for re-entry.
C
      IF ( IFLAG. GT. 0 ) THEN
         ICALL = ICALL + 1
         IF ( ICALL .LE. MAXIT ) GO TO 20
      END IF
C
C  Terminal exit.
C
      CALL UREPRT( CALLS, CPU )
      GNORM    = ZERO
      DO 30 I  = 1, N
         GNORM = MAX( GNORM, ABS( G( I ) ) )
   30 CONTINUE
      WRITE ( IOUT, 2001 ) GNORM
      WRITE ( IOUT, 2010 )
      DO 40 I = 1, N
         WRITE( IOUT, 2020 ) XNAMES( I ), X( I ), G( I )
   40 CONTINUE
      WRITE ( IOUT, 2000 ) PNAME, N, CALLS(1), CALLS(2),
     *                     IFLAG, F, CPU(1), CPU(2)
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( 4( I10, / ), D10.3 )
 2001 FORMAT( /, ' Final norm of G  = ', 1P, D12.4 )
 2010 FORMAT( /, '                 X         G ' )
 2020 FORMAT(  1X, A10, 1P, 2D12.4 )
 2030 FORMAT(  /, ' ** Warning from VA15MA. The problem as stated',
     *            ' includes simple bounds. ', /,
     *            '    These bounds will be ignored. ' )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  VA15',     /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =        ', F8.2 /
     *    ,' # objective gradients   =        ', F8.2 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
      END


c     DEMONSTRATE DCPDRV, DCPINT, AND DCPVAL.
c>> 2001-05-22 DRDCPVAL Krogh Minor change for making .f90 version.
c>> 1997-05-29 DRDCPVAL Krogh Special code for C conversion.
c>> 1996-05-28 DRDCPVAL Krogh Added external statement.
c>> 1994-10-19 DRDCPVAL Krogh  Changes to use M77CON
c>> 1987-12-09 DRDCPVAL Lawson  Initial Code.
c--D replaces "?": DR?CPVAL, ?CPDRV, ?CPINT, ?CPVAL
c
      external DCPVAL
c++ Code for .C. is inactive
c%%   long int i;
c++ End
      integer NQ, NR
      double precision     P(6),Q(7),R(6),Z,DCPVAL
      data     P/ 5.D0, 2.D0, 10.D0, 8.D0, 6.D0, 4.D0 /
c
      call DCPINT(P,3,Q,NQ)
      call DCPDRV(Q,NQ,R,NR)
      Z=DCPVAL(Q,NQ,6.D0)-DCPVAL(Q,NQ,4.D0)
c++ Code for ~.C. is active
      write(*,1000) P,Q,R,Z
 1000 format(21X,'P =',2F4.0,2X,4F7.2//' INTEGRAL OF P.      Q ='
     *,2F4.0,2X,5F7.2//' DERIVATIVE OF Q.    R =',2F4.0,2X,4F7.2/
     */' DEFINITE INTEGRAL.  Z =',F20.8)
c++ Code for .C. is inactive
c%%   printf( "                     P =%4.0f%4.0f  ", p[0], p[1]);
c%%   for(i=2L; i < sizeof(p)/sizeof(p[1]); i++)
c%%           printf( "%7.2f", p[i] );
c%%   printf( "\n INTEGRAL OF P.      Q =%4.0f%4.0f  ", q[0], q[1]);
c%%   for(i=2L; i < sizeof(q)/sizeof(q[1]); i++)
c%%           printf( "%7.2f", q[i] );
c%%   printf( "\n DERIVATIVE OF Q.    R =%4.0f%4.0f  ", r[0], r[1]);
c%%   for(i=2L; i < sizeof(r)/sizeof(r[1]); i++)
c%%           printf( "%7.2f", r[i] );
c%%   printf( "\n DEFINITE INTEGRAL.  Z =%7.2f\n", z );
c++ End
      stop
      end


! { dg-do run }
!
! PR fortran/40675
!
! Fortran 77 just had: "The value of a signed zero is the same as
! the value of an unsigned zero." and g77 returned for SIGN(1.0, -0.0) = 1.0
!
! Fortran 95+ has for SIGN: "Case  (iv):  If B is of type real and is zero,
! then ... (c) If B is negative real zero, the value of the result is -|A|".
! On architectures, where signed zeros are supported, gfortran's SIGN thus
! returns for B=-0.0 the -|A|.
!
program s
   x = sign(1.,0.)
   y = sign(1.,-0.)
   if (x /=  1.) STOP 1
   if (y /= -1.) STOP 2
   x = 1.
   y = 0.
   x = sign(x, y)
   y = sign(x, -y)
   if (x /=  1.) STOP 3
   if (y /= -1.) STOP 4
end program s


#include "Config.fpp"

module mod_cosine_signal

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_purecose_pulse'
 !
 !          Purpose:
 !                   Pure cosine signal pulse
 !
 !
 !          History:
 !                        Date: 05-08-2017
 !                        Time: 13:19 GMT+2
 !          Modified:
 !                    Bernard Gingold on: 12-03-2018, 17:05 GMT+2
 !                   1) Refactoring to Fortran 2003 standard.
 !                   2) Removing unnecessary type-bound members
 !                   3) Adding computational subroutines (additive noise)
 !                   4) Removing unnecessary destructor,copy and initialization subroutines.
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

    use module_kinds, only : I32P, R64P
    use mod_code_timing
    use mod_complex_arithm , only : vcmag
    use mod_jonesvec
    implicit none

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_COSINE_SIGNAL_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_COSINE_SIGNAL_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_COSINE_SIGNAL_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_COSINE_SIGNAL_FULLVER = 1000*MOD_COSINE_SIGNAL_MAJOR+100*MOD_COSINE_SIGNAL_MINOR + &
                                                                    10*MOD_COSINE_SIGNAL_MICRO

    ! Module/file creation date
    character(*),  parameter, public :: MOD_COSINE_SIGNAL_CREATE_DATE = "05-08-2017 13:19 +00200 (SAT 05 AUG 2017 GMT+2)"

    ! Module build date/time (should be set to latest build date/time)
    character(*),  parameter, public :: MOD_COSINE_SIGNAL_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_COSINE_SIGNAL_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Midule short description
    character(*),  parameter, public :: MOD_COSINE_SIGNAL_DESCRIPT = "Cosine complex domain implementation."

    integer(I32P), parameter, private :: MINSAMP = 32

    real(R64P),    parameter, private :: MINFREQ = 1.0e+7_R64P

    real(R64P),    parameter, private :: NS = 0.000000001_R64P

    real(R64P),    parameter, private :: TWOPI = 6.283185307179586476925286766559_R64P

    real(R64P),    parameter, private :: c = 3._R64P*1.0e+8_R64P

    real(R64P),    parameter, private :: SMALLTS = 0.0000152587890625_R64P ! smallest time step = 1/2^-16

    !======================================================
    !  Type: CosineSignal_t
    !======================================================

    type :: CosineSignal_t

        private

        ! derived type components

        ! Pulse name
        character(len=64) :: m_name

        ! Signal id .i.e cardinal number in signal train
        integer(I32P)     :: m_sid

        ! Number of samples
        integer(I32P)     :: m_nsamp

        ! Signal duration
        real(R64P)        :: m_dur

        ! Starting time-point of samples measurement
        real(R64P)        :: m_initime

        ! Samples interval
        real(R64P)        :: m_sinterv

        ! Carrier frequency
        real(R64P)        :: m_cfreq

        ! Evnevlope signal frequency
        real(R64P)        :: m_envfreq

        real(R64P)        :: m_tstep ! time step

        ! Jones Vector contains amplitudes of voltage
        ! i.e. Enl,Enk
        !complex(R64P), dimension(2) :: m_jvec
        type(JonesVector_t), allocatable, dimension(:), public :: m_jvec
        ! Electric field wave component.
        ! Phasor representation.
        complex(R64P), allocatable, dimension(:),       public :: m_E
!DIR$   ATTRIBUTES ALIGN : 64 :: m_E

        ! Signal enevelope i.e natural envelope  set to 1
        real(R64P), allocatable, dimension(:),          public :: m_nenvp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_nenvp

        ! Signal phase
        real(R64P), allocatable, dimension(:),          public :: m_phi
!DIR$   ATTRIBUTES ALIGN : 64 :: m_phi

        ! Signal canonical form i.e. S(t) = gc(t)*cos(wct)-gs(t)*sin(wct)
        complex(R64P), allocatable, dimension(:),       public :: m_canform
!DIR$   ATTRIBUTES ALIGN : 64 :: m_canform

        ! Signal basic form i.e. S(t) = g(t)*cos[wct+phi(t)]
        real(R64P), allocatable, dimension(:),          public :: m_basform
!DIR$   ATTRIBUTES ALIGN : 64 :: m_basform
        ! Signal complex envelope
        complex(R64P), allocatable, dimension(:),       public :: m_cenvp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_cenvp

        ! Signal amplitude  A(phi,theta)/r used forcalculation electric field
        ! far from emmiter(antenna)
        real(R64P), allocatable, dimension(:),          public :: m_amp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_amp

        ! Time-averaged power density
        ! To be properly implemented
        complex(R64P), allocatable, dimension(:),       public :: m_S
!DIR$   ATTRIBUTES ALIGN : 64 :: m_S

        contains

        !========================================
        !  Constructor subroutines
        !========================================

        ! Constructor creates pure cosine pulse

        procedure, pass(this), public :: cosine_signal

        procedure, pass(this), public :: phase_noise_cosine_signal

        procedure, pass(this), public :: additive_noise_cosine_signal

        !==========================================52
        !   Getter functions
        !==========================================52

        procedure, pass(this), public :: get_name

        procedure, pass(this), public :: get_pid

        procedure, pass(this), public :: get_nsamp

        procedure, pass(this), public :: get_dur

        procedure, pass(this), public :: get_initime

        procedure, pass(this), public :: get_sinterv

        procedure, pass(this), public :: get_cfreq

        procedure, pass(this), public :: get_envfreq

        procedure, pass(this), public :: get_tstep

        !==================================================60
        ! Computational subroutines
        !==================================================60

        procedure, pass(this), public :: dphi_dt

        procedure, pass(this), public :: analytic_signal

        !==============================================56
        ! write/read subroutines
        !==============================================56

        procedure, nopass,     public :: read_state

        procedure, nopass,     public :: write_state

        !==============================================56
        ! write/read subroutines
        !==============================================56

        procedure, pass(this), public :: dbg_info

        !===============================================
        !   Generic operators
        !===============================================
        procedure, public :: copy_assign

        generic :: assignment (=) => copy_assign

    end type CosineSignal_t

    interface CosineSignal_t
         procedure :: constructor
    end interface CosineSignal_t

    contains

    !======================================================60
    ! @subroutine:  constructor
    !               default_signal (no physical meaning)
    !======================================================60
   type(CosineSignal_t) function constructor(name,sid,nsamp,dur,logging, &
                                            verbose,filename,append      )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_PINF, LAM_MINSAMP

          character(len=*),         intent(in)    :: name
          integer(I32P),            intent(in)    :: sid
          integer(I32P),            intent(inout) :: nsamp
          real(R64P),               intent(in)    :: dur
          logical(I32P),            intent(in)    :: verbose,logging
          character(len=*),         intent(in)    :: filename
          logical(I32P),            intent(in)    :: append
          ! Locals

          integer(I32P)      :: aerr
          character(len=256) :: emsg
          ! Start of executable statements

          if(nsamp < 32) then
              nsamp = LAM_MINSAMP
          end if

          ! Begin construction
          constructor%m_name     = name
          constructor%m_sid      = sid
          constructor%m_nsamp    = nsamp
          constructor%m_dur      = dur
          constructor%m_initime  = LAM_PINF
          constructor%m_sinterv  = LAM_PINF
          constructor%m_cfreq    = LAM_PINF
          constructor%m_envfreq  = LAM_PINF
          constructor%m_tstep    = LAM_PINF

          associate(n=>constructor%m_nsamp)
              allocate(constructor%m_jvec(n),    &
                       constructor%m_E(n),       &
                       constructor%m_nenvp(n),   &
                       constructor%m_phi(n),     &
                       constructor%m_canform(n), &
                       constructor%m_basform(n), &
                       constructor%m_cenvp(n),   &
                       constructor%m_amp(n),     &
                       constructor%m_S(n),       &
                       STAT=aerr,     &
                       ERRMSG=emsg)
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,    &
                                             "logger:308 --> mod_cosine_signal/constructor: Memory Allocation Failure!", &
                                             "mod_cosine_signal/constructor:308 -- Memory Allocation Failure!"  , &
                                             emsg,__LINE__ )
          end if
          constructor%m_jvec    = JonesVector_t()
          constructor%m_E       = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_nenvp   = LAM_PINF
          constructor%m_phi     = LAM_PINF
          constructor%m_canform = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_basform = LAM_PINF
          constructor%m_cenvp   = CMPLX(LAM_PINF,LAM_PINF,R64P)
          constructor%m_amp     = LAM_PINF
          constructor%m_S       = CMPLX(LAM_PINF,LAM_PINF,R64P)
    end function constructor

    !======================================================60
    !  @subroutine: cosine_signal
    !======================================================60
    subroutine cosine_signal(this,ierr,dur,initime, &
                            sinterv,cfreq,envfreq,tstep,r,c1,c2,logging,   &
                            verbose,filename,append,profiling,qpctimer   )
          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PINF,LAM_2PI,LAM_c
          class(CosineSignal_t),       intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(in)    :: dur,initime,tstep
          real(R64P),                  intent(inout) :: sinterv
          real(R64P),                  intent(inout) :: cfreq,envfreq
          real(R64P), dimension(:),    intent(in)    :: r ! range
!DIR$     ASSUME_ALIGNED r:64
          complex(R64P), dimension(:), intent(in)    :: c1,c2
!DIR$     ASSUME_ALIGNED c1:64,c2:64
          logical(I32P),            intent(in)    :: logging,verbose
          character(len=*),         intent(in)    :: filename
          logical(I32P),            intent(in)    :: append,profiling
          type(QPCTimer_t),         intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          integer(I32P) :: i,aerr
          real(R64P)    :: insamp,delta,t,t2,tc,ts
          complex(R64P), allocatable, dimension(:) :: tmp
          real(R64P), allocatable, dimension(:) :: ct
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: ct
          ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
          if(dur < LAM_ZR8) then
              ierr = -1_I32P
              return
          end if
          this%m_dur     = dur
          this%m_initime = initime
          this%m_sinterv = sinterv
          this%m_cfreq   = cfreq
          this%m_envfreq = envfreq
          this%m_tstep   = tstep
          associate(n=>this%m_nsamp)
              allocate(  tmp(n),            &
                         ct(n),             &
                         STAT=aerr,     &
                         ERRMSG=emsg)
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:390 --> mod_cosine_signal/cosine_signal: Memory Allocation Failure!"   , &
                                             "mod_cosine_signal/cosine_signal:390 -- Memory Allocation Failure"  , &
                                             emsg,__LINE__ )
          end if
          tmp = CMPLX(LAM_PINF,LAM_PINF,R64P)
          ct  = LAM_PINF
          delta = 0._R64P
          t = 0._R64P
          t2 = 0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          if(profiling) then
               call qpctimer_start(qpctimer,ifail)
               if(ifail == 0) then
                    write(ERROR_UNIT,*) "cosine_signal: qpctimer_start failed to query performance frequency counter!!"
               end if
          end if
           ! Create Jones vector field.
          do i = 1_I32P, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
          do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               t2 = t-r(i)/LAM_c
               this%m_phi(i) = LAM_2PI*this%m_freq*t2
               !this%m_amp(i) = this%m_amp(i)/this%m_r(i)
               this%m_E(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
               !tmp(i) = this%m_E(i) ! copy signal components to temporaray arary.
               !this%m_E(i) = this%m_E(i)*this%m_amp(i)
          end do
           ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               ct(i) = t ! to be used for creation canonical form
               this%m_phi(i) = LAM_2PI*this%m_freq*t
               tmp(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi))
          end do
           ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
               tc = this%m_nenvp(i)*DCOS(this%m_phi(i))   ! gc(t)
               ts = this%m_nenvp(i)*DSIN(this%m_phi(i))   ! gs(t)
               this%m_cenvp(i) = DCMPLX(tc,ts)
               this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
               this%m_basform(i) = DREAL(this%m_canform(i)) ! base form
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1, this%m_nsamp
              this%m_S(i) =  0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.00265251989389920424403183023873_R64P

          end do
         if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "cosine_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "cosine_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine cosine_signal

    !======================================================60
    !  @subroutine: phase_noise_cosine_signal
    !              Physical representation of Cosine
    !              Signal.
    !              This signal is corrupted by phase additive
    !              noise.
    !======================================================60
     subroutine phase_noise_cosine_signal(this,ierr,dur,initime, &
                            sinterv,cfreq,envfreq,tstep,r,phinoise, &
                            logging,verbose,filename,append,profiling,qpctimer )
          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PINF,LAM_2PI,LAM_c
          class(Cosine_Signal_t),   intent(inout)    :: this
          integer(I32P),            intent(inout)    :: ierr
          real(R64P),               intent(in)       :: dur,initime,sinterv, &
                                                        cfreq,envfreq,tstep
          real(R64P), dimension(:), intent(in)       :: r
!DIR$     ASSUME_ALIGNED r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          real(R64P), dimension(:),    intent(in)    :: phinoise
!DIR$     ASSUME_ALIGNED phinoise:64
          logical(I32P),               intent(in)    :: logging,verbose
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
          character(len=256) :: emsg
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          integer(I32P) :: i,aerr
          real(R64P)    :: insamp,delta,t,t2,tc,ts,tn
          complex(R64P), allocatable, dimension(:) :: tmp
          real(R64P), allocatable, dimension(:) :: ct
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: ct
          ! Start of executable ststemetns
          if(ierr < 0_I32P) ierr = 0_I32P
          if(dur  < LAM_ZR8) then
              ierr = -1_I32P
              return
          end if
          this%m_dur     = dur
          this%m_initime = initime
          this%m_sinterv = sinterv
          this%m_cfreq   = cfreq
          this%m_envfreq = envfreq
          this%m_tstep   = tstep
          associate(n=>this%m_nsamp)
               allocate(tmp(n),    &
                        ct(n),     &
                        STAT=aerr, &
                        ERRMSG=emsg )
          end associate
          if(aerr /= 0) then
              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:512 --> mod_cosine_signal/phase_noise_cosine_signal: Memory Allocation Failure!"   , &
                                             "mod_cosine_signal/phase_noise_cosine_signal:512 -- Memory Allocation Failure"  , &
                                             emsg,__LINE__ )
          end if
          tmp = CMPLX(LAM_PINF,LAM_PINF,R64P)
          ct  = LAM_PINF
          delta = 0._R64P
          t = 0._R64P
          t2 = 0._R64P
          tn =  0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          if(profiling) then
               call qpctimer_start(qpctimer,ifail)
               if(ifail == 0) then
                    write(ERROR_UNIT,*) "phase_noise_cosine_signal: qpctimer_start failed to query performance frequency counter!!"
               end if
          end if
           ! Create Jones vector field.
          do i = 1_I32P, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
         do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               t2 = t-r(i)/LAM_c
               tn = t2 + phinoise(i)
               this%m_phi(i) = LAM_2PI*this%m_freq*tn
               !this%m_amp(i) = this%m_amp(i)/this%m_r(i)
               this%m_E(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
               !tmp(i) = this%m_E(i) ! copy signal components to temporaray arary.
               !this%m_E(i) = this%m_E(i)*this%m_amp(i)
         end do
            ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               tn = t+phinoise(i)
               ct(i) = tn ! to be used for creation canonical form
               this%m_phi(i) = LAM_2PI*this%m_freq*tn
               tmp(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi))
          end do
           ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
               tc = this%m_nenvp(i)*DCOS(this%m_phi(i))   ! gc(t)
               ts = this%m_nenvp(i)*DSIN(this%m_phi(i))   ! gs(t)
               this%m_cenvp(i) = DCMPLX(tc,ts)
               this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
               this%m_basform(i) = DREAL(this%m_canform(i)) ! base form
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1, this%m_nsamp
              this%m_S(i) =  0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.00265251989389920424403183023873_R64P

          end do
         if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "phase_noise_cosine_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "phase_noise_cosine_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
     end subroutine phase_noise_cosine_signal

    !======================================================60
    !  @subroutine: additive_noise_cosine_signal
    !              Physical representation of Cosine
    !              signal.
    !              This signal is corrupted by phase additive
    !              noise and by background additive noise.
    !======================================================60
    subroutine additive_noise_cosine_signal(this,ierr,dur,initime, &
                            sinterv,cfreq,envfreq,tstep,r,h,v,phinoise,bnoise, &
                            logging,verbose,filename,append,profiling,qpctimer )
          use mod_print_error,  only : handle_fatal_memory_error ,  &
                                        stderr
          use mod_constants,    only : LAM_ZR8,LAM_PINF,LAM_2PI,LAM_c

          class(Cosine_Signal_t),   intent(inout)    :: this
          integer(I32P),            intent(inout)    :: ierr
          real(R64P),               intent(in)       :: dur,initime,sinterv, &
                                                        cfreq,envfreq,tstep
          real(R64P), dimension(:), intent(in)       :: r
!DIR$     ASSUME_ALIGNED r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          real(R64P), dimension(:),    intent(in)    :: phinoise,bnoise
!DIR$     ASSUME_ALIGNED phinoise:64,bnoise:64
          logical(I32P),               intent(in)    :: logging,verbose
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
          character(len=256) :: emsg
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          integer(I32P) :: i,aerr
          real(R64P)    :: insamp,delta,t,t2,tc,ts,tn
          complex(R64P), allocatable, dimension(:) :: tmp
          real(R64P), allocatable, dimension(:) :: ct
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: ct
          ! Start of executable ststemetns
          if(ierr < 0_I32P) ierr = 0_I32P
          if(dur  < LAM_ZR8) then
              ierr = -1_I32P
              return
          end if
          this%m_dur     = dur
          this%m_initime = initime
          this%m_sinterv = sinterv
          this%m_cfreq   = cfreq
          this%m_envfreq = envfreq
          this%m_tstep   = tstep
          associate(n=>this%m_nsamp)
               allocate(tmp(n),    &
                        ct(n),     &
                        STAT=aerr, &
                        ERRMSG=emsg )
          end associate
          if(aerr /= 0) then
              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:643 --> mod_cosine_signal/additive_noise_cosine_signal: Memory Allocation Failure!"   , &
                                             "mod_cosine_signal/additive_noise_cosine_signal:643 -- Memory Allocation Failure"  , &
                                             emsg,__LINE__ )
          end if
          tmp = CMPLX(LAM_PINF,LAM_PINF,R64P)
          ct  = LAM_PINF
          delta = 0._R64P
          t = 0._R64P
          t2 = 0._R64P
          tn =  0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          if(profiling) then
               call qpctimer_start(qpctimer,ifail)
               if(ifail == 0) then
                    write(ERROR_UNIT,*) "additive_noise_cosine_signal: qpctimer_start failed to query performance frequency counter!!"
               end if
          end if
           ! Create Jones vector field.
          do i = 1_I32P, this%m_nsamp
              this%m_jvec(i) = JonesVector_t(h(i),v(i))
          end do
         do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               t2 = t-r(i)/LAM_c
               tn = t2 + phinoise(i)
               this%m_phi(i) = LAM_2PI*this%m_freq*tn
               !this%m_amp(i) = this%m_amp(i)/this%m_r(i)
               this%m_E(i) = DCMPLX(bnoise(i)+DCOS(this%m_phi(i)),bnoise(i)+DSIN(this%m_phi(i)))
               !tmp(i) = this%m_E(i) ! copy signal components to temporaray arary.
               !this%m_E(i) = this%m_E(i)*this%m_amp(i)
         end do
            ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1_I32P, this%m_nsamp
               this%m_initime = this%m_initime+this%m_tstep
               delta = DBLE(i)*insamp
               t = this%m_initime*delta
               tn = t+phinoise(i)
               ct(i) = tn ! to be used for creation canonical form
               this%m_phi(i) = LAM_2PI*this%m_freq*tn
               tmp(i) = DCMPLX(bnoise(i)+DCOS(this%m_phi(i)),bnoise(i)+DSIN(this%m_phi))
          end do
           ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
               tc = this%m_nenvp(i)*DCOS(this%m_phi(i))   ! gc(t)
               ts = this%m_nenvp(i)*DSIN(this%m_phi(i))   ! gs(t)
               this%m_cenvp(i) = DCMPLX(tc,ts)
               this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
               this%m_basform(i) = DREAL(this%m_canform(i)) ! base form
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1, this%m_nsamp
              this%m_S(i) =  0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.00265251989389920424403183023873_R64P

          end do
         if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(stderr,*) "additive_noise_cosine_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(stderr,*) "additive_noise_cosine_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine additive_noise_cosine_signal

    !======================================================60
    ! ************* Getter pure functions ****************
    !======================================================60

    pure function get_name(this) result(name)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          character(len=64) :: name
          ! Start of executable statements
          name = this%m_name
    end function

    pure function get_pid(this) result(pid)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: pid
          ! Start of executable satteements
          pid = this%m_pid
    end function

    pure function get_nsamp(this) result(nsamp)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nsamp
          ! Start of executable statements
          nsamp = this%m_nsamp
    end function

    pure function get_initime(this) result(initime)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: initime
          ! Start of executable statements
          initime = this%m_initime
    end function

    pure function get_sinterv(this) result(sinterv)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: sinterv
          ! Start of executable statements
          sinterv = this%m_sinterv
    end function

    pure function get_cfreq(this) result(cfreq)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: cfreq
          ! Start of executable statements
          cfreq = this%m_cfreq
    end function

    pure function get_envfreq(this) result(envfreq)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: envfreq
          ! Start of executable sattements
          envfreq = this%m_envfreq
    end function

    pure function get_tstep(this) result(tstep)
          implicit none
          class(CosineSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: tstep
          ! Start of executable statements
          tstep = this%m_tstep
    end function

    !======================================================60
    ! sbroutine: dphi_dt
    !            Phase signal time derivative
    !======================================================60
    subroutine dphi_dt(this,dphi,sfac)
          use mod_constants, only : LAM_MEPS8
          class(CosineSignal_t),    intent(in)     :: this
          real(R64P), dimension(:), intent(out)    :: dphi
          integer(I64P),            intent(inout)  :: sfac ! scaling factor up to 16 digits of precision
          ! Locals
          integer(I64P) :: i,
          real(R64P)    :: eps,tmp,isfac  ! eps**0.3
          ! Start of executable statements
          if(sfac.LE.0) then
              sfac = 1000000000000000_I64P
          end if
          isfac = 1._R64P/DBLE(sfac)
          eps = LAM_MEPS8**0.333333333333333333333333_R64P
          do i = 2, this%m_nsamp-1
              tmp = this%m_phi(i+1)-this%m_phi(i-1) ! Consider using CADNA to test for cancellation errors
              dphi(i) = this%m_phi(i+1)-this%m_phi(i-1)/ &
                        (2._R64P*eps*DMAX1(DABS(tmp),isfac)*DSIGN(tmp,tmp))
          end do
    end subroutine

    !======================================================
    !  subroutine: analytic signal
    !              Using this formula:
    !======================================================
    subroutine analytic_signal(this,asig,tmplen,wlen,iplen,profiling,qpctimer)
          use mod_fftsg, only : rdft

          class(CosineSignal_t),    intent(inout) :: this
          complex(R64P), dimension(:), intent(out)   :: asig ! analytic signal
          integer(I32P),               intent(in)    :: tmplen ! nsamp-1
          integer(I32P),               intent(in)    :: wlen ! nsamp/2-1
          integer(I32P),               intent(in)    :: iplen ! 2+2**(int(log(n/2+0.5)/log(2.0))/2)
          logical(I32P),               intent(in)    :: profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          integer(I32P) :: i
          real(R64P),    dimension(0:tmplen) :: tmp,tmp2
          real(R64P),    dimension(0:wlen)   :: w
          integer(I32P), dimension(0:iplen)  :: ip
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp2
!DIR$     ATTRIBUTES ALIGN : 64 :: w
          ! Start of executable statements
          ! Copy real part of canonical representation
          if(profiling) then
             call qpctimer_start(qpctimer,ifail)
             if(ifail.EQ.0) then
                 write(stderr,*) "analytic_signal:859, qpctimer_start failed to query performance frequency counter!!"
             end if
          end if
!DIR$     SIMD VECTORLENGTHFOR(REAL(KIND=8))
          do i = 0, tmplen
              tmp(i) = DREAL(this%m_canform(i))   ! Copy of real part
          end do
          ! Real FFT
          ip(0) = 0
          call rdft(tmplen,1,tmp,ip,w)
!DIR$     SIMD VECTORLENGTHFOR(REAL(KIND=8))
          do i = 0, tmplen
              tmp2(i) = tmp(i)+DSIGN(tmp(i),tmp(i))*tmp(i)  ! Construct argument to Inverse FFT
          end do
          call rdft(tmplen,-1,tmp2,ip,w)  ! Inverse FFT
          ! Construct analytic signal content
          do  i = 0, tmplen
              asig(i) = DCMPLX(DREAL(this%m_conform(i)),tmp2(i))
          end do
           if(profiling) then
               if(ifail.EQ.0) then
                   call qpctimer_stop(qpctimer,ifail)
                   call qpctimer_delta(qpctimer,bfail)
                   if(bfail .EQ. .false.) then
                        call qpctimer_print(qpctimer)
                   else
                        write(stderr,*) "analytic_signal:884 -- qpctimer_delta: failed to compute delta measurement!!"
                   end if
               else
                       write(stderr,*) "analytic_signal:884 -- Unable to read performance counter -- fatal!!"
               end if
           end if

    end subroutine  analytic_signal

      !============================================
    !   Read/write procedures
    !============================================
    subroutine read_state(this,form,unit,ioerr)

          class(CosineSignal_t), intent(in) :: this
          character(len=*),        intent(in) :: form
          integer(I32P),           intent(in) :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(CosineSignal_t), intent(in) :: this
          character(len=*),        intent(in) :: form
          integer(I32P),           intent(in) :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine write_state

    !======================================================60
    ! subroutine: dbg_info
    !             Print unformatted stream to screen
    !======================================================60
    subroutine dbg_info(this)

          class(CosineSignal_t), intent(in) :: this
          ! Locals
          character(len=40) :: dstr,tstr
          ! Start of executable statements
          call DATE_AND_TIME(date=dstr,time=tstr)
          print*, "======================================================"
          print*, "   ***Printing components of CosineSignal_t***"
          print*, "   printing subroutine called at: " , &
                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                     stime(1:2),":",stime(3:4),":",stime(5:6)
          print*, "           Dumping scalar components "
          print*, "======================================================"
          print*, "Name:              ", this%m_name
          print*, "Signal ID:          ",this%m_sid
          print*, "Number of samples: ", this%m_nsamp
          print*, "Pulse duration:    ", this%m_dur
          print*, "Pulse initial time:", this%m_initime
          print*, "Sample interval:   ", this%m_sinterv
          print*, "Carrier frequency: ", this%m_cfreq
          print*, "Envelope frequency:", this%m_envfreq
          print*, "Time step:         ", this%m_tstep
          print*, "           Dumping array components "
          print*, "====================================================="

          print*, "Signal polarization:", this%m_jvec
          print*, "Electric field:     ", this%m_E
          print*, "Natural Envelope:   ", this%m_nenvp
          print*, "Phase:              ", this%m_phi
          print*, "Canonical form:     ", this%m_canform
          print*, "Base form:          ", this%m_basform
          print*, "Complex envelope:   ", this%m_cenvp
          print*, "Amplitude:          ", this%m_amp
          print*, "Time-average power: ", this%m_S
          print*,"======================================================"

          print*, "           End                                       "
    end subroutine  dbg_info

    !============================================
    !  Operator assignment (=)
    !============================================
    subroutine copy_assign(lhs,rhs)
          class(CosineSignal_t),    intent(inout) :: lhs
          class(CosineSignal_t),    intent(in)    :: rhs
          ! Start of executable statements
          this%m_name    = rhs%m_name
          this%m_sid     = rhs%m_sid
          this%m_nsamp   = rhs%m_nsamp
          this%m_dur     = rhs%m_dur
          this%m_initime = rhs%m_initime
          this%m_sinterv = rhs%m_sinterv
          this%m_cfreq   = rhs%m_cfreq
          this%m_envfreq = rhs%m_envfreq
          this%m_tstep   = rhs%m_tstep
          this%m_jvec    = rhs%m_jvec
          this%m_E       = rhs%m_E
          this%m_nenvp   = rhs%m_nenvp
          this%m_phi     = rhs%m_phi
          this%m_canform = rhs%m_canform
          this%m_basform = rhs%m_basform
          this%m_cenvp   = rhs%m_cenvp
          this%m_amp     = rhs%m_amp
          this%m_S       = rhs%m_S
    end subroutine copy_assign

end module mod_cosine_signal


!  The following function was taken from the book "Numerical Recipes in
!  FORTRAN, the art of scientific computing (2nd Ed.), by William H. Press,
!  Saul A. Teukolsky, William T. Vetterling, and Brian P. Flannery (Cambridge
!  University Press, 1992).

      FUNCTION julday(mm,id,iyyy)
      INTEGER julday,id,iyyy,mm,IGREG
      PARAMETER (IGREG=15+31*(10+12*1582))
      INTEGER ja,jm,jy
      jy=iyyy
      if (jy.eq.0) then
        print *, 'julday: there is no year zero'
        stop
      endif
      if (jy.lt.0) jy=jy+1
      if (mm.gt.2) then
        jm=mm+1
      else
        jy=jy-1
        jm=mm+13
      endif
      julday=int(365.25*jy)+int(30.6001*jm)+id+1720995
      if (id+31*(mm+12*iyyy).ge.IGREG) then
        ja=int(0.01*jy)
        julday=julday+2-ja+int(0.25*ja)
      endif
      return
      END

      SUBROUTINE CALDAT (JULIAN,MM,ID,IYYY)
C
C   ROUTINE CONVERTS JULIAN DAY TO MONTH, DAY, & YEAR.
C   THIS CODE IS LIFTED FROM THE BOOK:
C   W.H. PRESS ET AL., NUMERICAL RECIPES, CAMBRIDGE UNIV. PRESS, 1986.
C   THE ONLY MODIFICATION IS THAT REAL ARITHMETIC IS DONE IN R*8.
C
C   THE ROUTINE OUTPUTS THE MONTH, DAY, AND YEAR ON WHICH THE
C   SPECIFIED JULIAN DAY STARTED AT NOON.
C
C   TO CONVERT MODIFIED JULIAN DAY, CALL THIS ROUTINE WITH
C     JULIAN = MJD + 2400001
C
      PARAMETER (IGREG=2299161)
      IF (JULIAN.GE.IGREG) THEN
         JALPHA=INT((DBLE(JULIAN-1867216)-0.25D0)/36524.25D0)
         JA=JULIAN+1+JALPHA-INT(0.25D0*DBLE(JALPHA))
      ELSE
         JA=JULIAN
      ENDIF
      JB=JA+1524
      JC=INT(6680.D0+(DBLE(JB-2439870)-122.1D0)/365.25D0)
      JD=365*JC+INT(0.25D0*DBLE(JC))
      JE=INT(DBLE(JB-JD)/30.6001D0)
      ID=JB-JD-INT(30.6001D0*DBLE(JE))
      MM=JE-1
      IF (MM.GT.12) MM=MM-12
      IYYY=JC-4715
      IF (MM.GT.2) IYYY=IYYY-1
      IF (IYYY.LE.0) IYYY=IYYY-1
      RETURN
      END

      integer function err ( outstring, iret, ec )
      character *(*) outstring
      integer ec, rc, iret

      if (iret .EQ. 0) then
        err = iret
      else
        print *,"GFIO_",outstring
        iret = ec
        err = ec
      endif

      return
      end


      subroutine Gal_to_UVW(X,Y,Z,VX,VY,VZ,U,V,W)
C -------------------------------------------------------------------
C CHANGES FROM (VX,VY,VZ) CARTESIAN GALACTOCENTRIC VELOCITY VECTOR TO
C (U,V,W) VELOCITY VECTOR WITH U POINTING TOWARDS TO GC, V TOWARDS
C GALACTIC ROTATION AND W PERPENDICULAR TO THE GALACTIC PLANE
C WE NEED (X,Y,Z) TO COMPUTE THE POSITION ANGLE THETA.
c
C--------------------------------------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)

      PI=4.D0*DATAN(1.D0)

C POSITION ANGLE
      THETA=DATAN2(X,Y)
C ROTATION OF VX,VY OF ANGLE 270-THETA COUNTERCLOCKWISE
      ANGLE=3.D0*PI/2.D0-THETA
      CALL rot_antihorari(angle,VX,VY,VX2,VY2)
C SUBSTRACT THE DIFFERENTIAL ROTATION OF THE STAR
      R=DSQRT(X*X+Y*Y)
      CALL dV2(R,Z,W)
      U=VX2
      V=VY2!-W*R sense rotacio diferencial
      W=VZ
      RETURN
      END