      SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
*     .. Scalar Arguments ..
      REAL SD1,SD2,SX1,SY1
*     ..
*     .. Array Arguments ..
      REAL SPARAM(5)
*     ..
*
*  Purpose
*  =======
*
*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(SD1)*SX1,SQRT(SD2)*
*     SY2)**T.
*     WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     SFLAG=-1.E0     SFLAG=0.E0        SFLAG=1.E0     SFLAG=-2.E0
*
*       (SH11  SH12)    (1.E0  SH12)    (SH11  1.E0)    (1.E0  0.E0)
*     H=(          )    (          )    (          )    (          )
*       (SH21  SH22),   (SH21  1.E0),   (-1.E0 SH22),   (0.E0  1.E0).
*     LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
*     RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
*     VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
*
*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*     OF SD1 AND SD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
*
*  Arguments
*  =========
*
*
*  SD1    (input/output) REAL
*
*  SD2    (input/output) REAL
*
*  SX1    (input/output) REAL
*
*  SY1    (input) REAL
*
*
*  SPARAM (input/output)  REAL array, dimension 5
*     SPARAM(1)=SFLAG
*     SPARAM(2)=SH11
*     SPARAM(3)=SH21
*     SPARAM(4)=SH12
*     SPARAM(5)=SH22
*
*  =====================================================================
*
*     .. Local Scalars ..
      REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
     $     SQ2,STEMP,SU,TWO,ZERO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC ABS
*     ..
*     .. Data statements ..
*
      DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
      DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
*     ..

      IF (SD1.LT.ZERO) THEN
*        GO ZERO-H-D-AND-SX1..
         SFLAG = -ONE
         SH11 = ZERO
         SH12 = ZERO
         SH21 = ZERO
         SH22 = ZERO
*
         SD1 = ZERO
         SD2 = ZERO
         SX1 = ZERO
      ELSE
*        CASE-SD1-NONNEGATIVE
         SP2 = SD2*SY1
         IF (SP2.EQ.ZERO) THEN
            SFLAG = -TWO
            SPARAM(1) = SFLAG
            RETURN
         END IF
*        REGULAR-CASE..
         SP1 = SD1*SX1
         SQ2 = SP2*SY1
         SQ1 = SP1*SX1
*
         IF (ABS(SQ1).GT.ABS(SQ2)) THEN
            SH21 = -SY1/SX1
            SH12 = SP2/SP1
*
            SU = ONE - SH12*SH21
*
           IF (SU.GT.ZERO) THEN
             SFLAG = ZERO
             SD1 = SD1/SU
             SD2 = SD2/SU
             SX1 = SX1*SU
           END IF
         ELSE

            IF (SQ2.LT.ZERO) THEN
*              GO ZERO-H-D-AND-SX1..
               SFLAG = -ONE
               SH11 = ZERO
               SH12 = ZERO
               SH21 = ZERO
               SH22 = ZERO
*
               SD1 = ZERO
               SD2 = ZERO
               SX1 = ZERO
            ELSE
               SFLAG = ONE
               SH11 = SP1/SP2
               SH22 = SX1/SY1
               SU = ONE + SH11*SH22
               STEMP = SD2/SU
               SD2 = SD1/SU
               SD1 = STEMP
               SX1 = SY1*SU
            END IF
         END IF

*     PROCESURE..SCALE-CHECK
         IF (SD1.NE.ZERO) THEN
            DO WHILE ((SD1.LE.RGAMSQ) .OR. (SD1.GE.GAMSQ))
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (SD1.LE.RGAMSQ) THEN
                  SD1 = SD1*GAM**2
                  SX1 = SX1/GAM
                  SH11 = SH11/GAM
                  SH12 = SH12/GAM
               ELSE
                  SD1 = SD1/GAM**2
                  SX1 = SX1*GAM
                  SH11 = SH11*GAM
                  SH12 = SH12*GAM
               END IF
            ENDDO
         END IF

         IF (SD2.NE.ZERO) THEN
            DO WHILE ( (ABS(SD2).LE.RGAMSQ) .OR. (ABS(SD2).GE.GAMSQ) )
               IF (SFLAG.EQ.ZERO) THEN
                  SH11 = ONE
                  SH22 = ONE
                  SFLAG = -ONE
               ELSE
                  SH21 = -ONE
                  SH12 = ONE
                  SFLAG = -ONE
               END IF
               IF (ABS(SD2).LE.RGAMSQ) THEN
                  SD2 = SD2*GAM**2
                  SH21 = SH21/GAM
                  SH22 = SH22/GAM
               ELSE
                  SD2 = SD2/GAM**2
                  SH21 = SH21*GAM
                  SH22 = SH22*GAM
               END IF
            END DO
         END IF

      END IF

      IF (SFLAG.LT.ZERO) THEN
         SPARAM(2) = SH11
         SPARAM(3) = SH21
         SPARAM(4) = SH12
         SPARAM(5) = SH22
      ELSE IF (SFLAG.EQ.ZERO) THEN
         SPARAM(3) = SH21
         SPARAM(4) = SH12
      ELSE
         SPARAM(2) = SH11
         SPARAM(5) = SH22
      END IF

  260 CONTINUE
      SPARAM(1) = SFLAG
      RETURN
      END


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
! Three band model (3D)
module global_variables
! mathematical parameters
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zI = (0d0,1d0)
  real(8),parameter :: a_B=0.529177d0,Ry=13.6058d0

! Material parameter
  integer :: NKr,NKz,NKrz,NKrz_s,NKrz_e,NKrz_ave,NKrz_remainder
  integer,allocatable :: ikr_table(:),ikz_table(:)
  real(8) :: kr_max,kz_max,dkr,dkz
  real(8),allocatable :: kr(:),kz0(:),kz(:)
! d: (semi) core , v: valence, c: conduction
  real(8),parameter :: eps_d = -40d0/(2d0*Ry), eps_g = 1.52d0/(2d0*Ry)
  real(8),parameter :: mass_v = 0.57d0, mass_c = 0.067d0
  real(8),parameter :: mass_r = 1d0/(1d0/mass_v+1d0/mass_c)
  real(8),parameter :: piz_vc = 0.5d0*sqrt(eps_g/mass_r)
  real(8),parameter :: piz_dv = 1d0,piz_dc = 1d0
  real(8),parameter :: deps12_2 = (0.5d0/(2d0*Ry) )**2

! Time-propagation
  integer :: Nt
  real(8) :: dt
  real(8),allocatable :: eps(:,:)
  complex(8),allocatable :: zCt(:,:,:)
  real(8),allocatable :: Act(:),Act_dt2(:),jtz(:),jtz_intra(:),jtz_inter(:)
  character(20) :: envelope_1,envelope_2

! Laser parameters
  real(8) :: E0_1,omega_1,tpulse_1,omega_ev_1,tpulse_fs_1,Iwcm2_1
  real(8) :: E0_2,omega_2,tpulse_2,omega_ev_2,tpulse_fs_2,Iwcm2_2
  real(8) :: Tdelay_fs,Tdelay

! MPI
  include 'mpif.h'
  integer :: Myrank,Nprocs,ierr

! I/O
  integer,parameter :: nf_current = 21
  character(99),parameter :: cf_current = "current.out"
end module global_variables


module main
    implicit none

    contains

    real function hit_sphere(centre, radius, ray)

        use vec3_class
        use ray_mod

        implicit none

        type(vec3),  intent(IN) :: centre
        real,        intent(IN) :: radius
        type(ray_t), intent(IN) :: ray

        real :: a, c, discrim, half_b
        type(vec3) :: oc, a_tmp

        oc = ray%origin() - centre
        a_tmp = ray%direction()
        a = a_tmp%length_squared()
        half_b = oc .dot. ray%direction()
        c = oc%length_squared() - radius**2
        discrim = half_b**2 - a*c

        if(discrim < 0.)then
            hit_sphere = -1.
        else
            hit_sphere = (-half_b - sqrt(discrim)) / a
        end if

    end function hit_sphere

    subroutine write_colour(colour, samples_per_pixel)

        use iso_fortran_env, only : output_unit
        use vec3_class
        use utils, only : clamp

        implicit none

        type(vec3), intent(IN) :: colour
        integer, intent(IN) :: samples_per_pixel

        real :: r, g, b, scale

        r = colour%x
        g = colour%y
        b = colour%z

        scale = 1. / real(samples_per_pixel)
        r = sqrt(r * scale)
        g = sqrt(g * scale)
        b = sqrt(b * scale)

        write(output_unit,"(3(I3.1, 1x),A)") int(256*clamp(r, 0., 0.999)),int(256*clamp(g, 0., 0.999)),int(256*clamp(b, 0., 0.999))

    end subroutine write_colour

    recursive function ray_color(ray, world, depth) result(res)

        use vec3_class
        use ray_mod
        use material_mod
        use hittable_list_mod
        use utils, only : infinity

        implicit none

        type(ray_t), intent(IN) :: ray
        integer :: depth
        type(hittable_list), intent(IN) :: world

        type(hit_record) :: rec
        type(vec3) :: unit_direction, res, attenuation
        type(ray_t) :: scattered
        real :: t

        if(depth <= 0)then
            res = vec3(0., 0., 0.)
            return
        end if

        if(world%hit(ray, 0.001, infinity, rec))then
            if(rec%mat_ptr%scatter(ray, rec, attenuation, scattered))then
                res = attenuation * ray_color(scattered, world, depth-1)
                return
            end if
        end if

        unit_direction = ray%direction()
        unit_direction = unit_direction%magnitude()
        t = 0.5 * (unit_direction%y + 1.)
        res = (1. - t)*vec3(1., 1., 1.) + t*vec3(.5, .7, 1.)

    end function ray_color

    function random_scene() result(world)

        use utils, only : random
        use hittable_list_mod
        use sphere_mod
        use material_mod

        implicit none

        type(hittable_list) :: world
        class(material), pointer :: sphere_material
        type(sphere), target, save, allocatable :: sph(:)
        type(dielectric), target, save :: material1(530)
        type(lambertian), target, save :: ground_material, material2(530)
        type(metal), target, save :: material3(530)
        type(vec3) :: centre, albedo, tmp_vec
        integer :: cnter, a, b, i, mat1, mat2, mat3
        real :: choose_mat, fuzz

        ground_material = lambertian(vec3(0.5, 0.5, 0.5))
        allocate(world%list(530), sph(530))
        sph(1) = sphere(vec3(0., -1000., 0.), 1000., ground_material)
        do i = 1, 530
            allocate(world%list(i)%p, source=sph(i))
        end do
        world%list(1)%p => sph(1)

        cnter = 2
        mat1 = 1
        mat2 = 1
        mat3 = 1

        do a = -11, 11
            do b = -11, 11
                choose_mat = random()
                centre = vec3(a + .9*random(), .2, b + 0.9*random())

                tmp_vec = centre - vec3(4., .2, .0)
                if(tmp_vec%length() > 0.9)then
                    if(choose_mat < 0.8)then
                        !diffuse
                        albedo = random_vec3() * random_vec3()
                        material2(mat2) = lambertian(albedo)
                        sphere_material => material2(mat2)
                        mat2 = mat2 + 1
                        sph(cnter) = sphere(centre, 0.2, sphere_material)
                        world%list(cnter)%p => sph(cnter)
                        cnter = cnter + 1
                    elseif(choose_mat < 0.95)then
                        ! metal
                        albedo = random_vec3(0.5, 1.)
                        fuzz = random(0., 0.5)
                        material3(mat3) = metal(albedo, fuzz)
                        sphere_material => material3(mat3)
                        mat3 = mat3 + 1
                        sph(cnter) = sphere(centre, 0.2, sphere_material)
                        world%list(cnter)%p => sph(cnter)
                        cnter = cnter + 1
                    else
                        !glass
                        material1(mat1) = dielectric(1.5)
                        sphere_material => material1(mat1)
                        mat1 = mat1 + 1
                        sph(cnter) = sphere(centre, 0.2, sphere_material)
                        world%list(cnter)%p => sph(cnter)
                        cnter = cnter + 1
                    end if
                end if
                if(cnter >= 528)goto 10
            end do
        end do
10 continue
    material1(mat1+1) = dielectric(1.5)
    sph(cnter) = sphere(vec3(.0, 1., 0.), 1., material1(mat1+1))
    world%list(cnter)%p => sph(cnter)
    cnter = cnter + 1

    material2(mat2+1) = lambertian(vec3(0.4, 0.2, 0.1))
    sph(cnter) = sphere(vec3(-4., 1., 0.), 1., material2(mat2+1))
    world%list(cnter)%p => sph(cnter)
    cnter = cnter + 1

    material3(mat3+1) = metal(vec3(.7, .6, .5), 0.0)
    sph(cnter) = sphere(vec3(4., 1., 0.), 1., material3(mat3+1))
    world%list(cnter)%p => sph(cnter)

    end function random_scene

end module main
program p

    use iso_fortran_env, only : output_unit, error_unit
    use main
    use vec3_class
    use ray_mod
    use sphere_mod
    use hittable_list_mod
    use camera_mod
    use material_mod
    use utils, only : random, init_rng
    use omp_lib
    use tev_mod, only : tevipc

    implicit none

    type(tevipc) :: tev
    integer     :: image_width, image_height, i, j, s, samples_per_pixel, max_depth, progress, id
    real        :: aspect_ratio, u, v, dist_to_focus, aperture,x, y, z
    type(vec3)  :: pixel_color, lookat, lookfrom, vup
    type(ray_t) :: r

    real, allocatable :: rgb(:,:,:)

    ! type(sphere), allocatable, target :: sph(:)
    type(hittable_list) :: world
    type(camera) :: cam
    ! type(lambertian) :: material_ground, material_centre
    ! type(dielectric) :: material_left
    ! type(metal)      :: material_right

    tev = tevipc()

    !image
    aspect_ratio = 3. / 2.
    image_width = 500
    image_height = int(image_width / aspect_ratio)
    progress = image_height-1
    allocate(rgb(0:image_height-1, 0:image_width-1, 3))
    samples_per_pixel = 50
    max_depth = 10

    !world
    call init_rng()
    world = random_scene()
    ! material_ground = lambertian(vec3(.8, .8, 0.))
    ! material_centre = lambertian(vec3(.1, .2, 0.5))
    ! material_left = dielectric(1.5)
    ! material_right = metal(vec3(.8, .6, 0.2), .0)

    ! allocate(world%list(5), sph(5))
    ! do i = 1, 5
    !     allocate(world%list(i)%p, source=sph(i))
    ! end do

    ! sph(1) = sphere(vec3( 0.0, -100.5, -1.0), 100.0, material_ground)
    ! sph(2) = sphere(vec3( 0.0,    0.0, -1.0),   0.5, material_centre)
    ! sph(3) = sphere(vec3(-1.0,    0.0, -1.0),   0.5, material_left)
    ! sph(4) = sphere(vec3(-1.0,    0.0, -1.0),  -0.4, material_left)
    ! sph(5) = sphere(vec3( 1.0,    0.0, -1.0),   0.5, material_right)

    ! do i = 1, 5
    !     world%list(i)%p => sph(i)
    ! end do

    !camera
    lookfrom = vec3(13., 2., 3.)
    lookat = vec3(0., 0., 0.)
    vup = vec3(0., 1., 0.)
    aperture = 0.1
    ! dist_to_focus_vec = lookfrom - lookat
    dist_to_focus = 10.0!dist_to_focus_vec%length()
    cam = camera(lookfrom, lookat, vup, 20., aspect_ratio, aperture, dist_to_focus)
    call tev%create_image("RT", image_width, image_height, ["R", "G", "B"], .true.)
    !render
    ! write(output_unit,"(A,A,I4,1x,I3,A)")"P3",new_line("a"), image_width,image_height, new_line("a"),"255",new_line("a")
!$omp parallel default(none) shared(tev,progress,cam, rgb, samples_per_pixel, image_height, image_width, max_depth, world)&
!$omp& private(i, j, s, u, v, pixel_color, r, x, y, z, id)
    id = 0!omp_get_thread_num()

!$omp do
    do j = 0, image_width-1
        ! if(id == 0)then
        !     write(error_unit,"(A,I3.1)", advance="No")achar(27)//"[1000D"//"Scanlines remaing:",progress
        !     flush(error_unit)
        ! end if
        !$omp atomic
            progress = progress - 1
        do i = image_height-1,0,-1

            pixel_color = vec3(0., 0., 0.)
            do s = 1, samples_per_pixel
                u = real(j + random()) / (image_height-1.)
                v = real(i + random()) / (image_width-1.)
                r = cam%get_ray(u, v)
                pixel_color = pixel_color + ray_color(r, world, max_depth)
            end do
            x = pixel_color%x
            y = pixel_color%y
            z = pixel_color%z

            !$omp atomic
                rgb(image_height-1-i,j,1) = rgb(image_height-1-i,j,1) + x
            !$omp atomic
                rgb(image_height-1-i,j,2) = rgb(image_height-1-i,j,2) + y
            !$omp atomic
                rgb(image_height-1-i,j,3) = rgb(image_height-1-i,j,3) + z

if(mod(progress,10) == 0)then
!$omp critical
if(id == 0)call tev%update_image("RT", (rgb(:,:,1:1)), ["R"], 0, 0, .true., .true.)
if(id == 0)call tev%update_image("RT", (rgb(:,:,2:2)), ["G"], 0, 0, .true., .true.)
if(id == 0)call tev%update_image("RT", (rgb(:,:,3:3)), ["B"], 0, 0, .true., .true.)
!$omp end critical
end if
            ! call write_colour(pixel_color, samples_per_pixel)
        end do
    end do
    !$OMP end  do
    !$OMP end parallel
    ! do i = image_height-1, 0, -1
    !     do j = 0, image_width-1
    !         pixel_color = vec3(rgb(j,i,1), rgb(j,i,2), rgb(j,i,3))
    !         call write_colour(pixel_color, samples_per_pixel)
    !     end do
    ! end do
    ! write(error_unit,*)new_line("a")
    call tev%update_image("RT", (rgb(:,:,1:1)), ["R"], 0, 0, .true., .true.)
    call tev%update_image("RT", (rgb(:,:,2:2)), ["G"], 0, 0, .true., .true.)
    call tev%update_image("RT", (rgb(:,:,3:3)), ["B"], 0, 0, .true., .true.)

end program p


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE DVOL2D( COORD, DISP, LSTSN, NSEG, DELVOL,
     *   NDIM, AXI, NUMNP)

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

C     DESCRIPTION:
C       This routine computes the change in volume of a cavity formed
C       by the boundary of an element side set flag

C     FORMAL PARAMETERS:
C       COORD   REAL      Nodal Coordinates
C       DISP    REAL      Nodal Displacements
C       LSTSN   INTEGER   List of nodes on this boundary
C       LSTLEN  INTEGER   Length of node list
C       NSEG    INTEGER   Number of segments in this boundary
C       DELVOL  REAL      Change in volume of this cavity
C       NUMNP   INTEGER   Number of Nodes
C       AXI     LOGICAL   TRUE if axisymmetric mesh

C     CALLED BY:

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

      DIMENSION COORD(NUMNP, *), DISP(NUMNP, *), LSTSN(*)
      LOGICAL AXI
      PI = ATAN2(0.0, -1.0)

      DELVOL = 0.0

      DO 100 KSEG = 1 , NSEG
         J = LSTSN(2*KSEG)
         I = LSTSN(2*KSEG - 1)

         X1  = COORD(I,1)
         X2  = COORD(J,1)
         DX1 = DISP(I,1)
         DX2 = DISP(J,1)

         Y1  = COORD(I,2)
         Y2  = COORD(J,2)
         DY1 = DISP(I,2)
         DY2 = DISP(J,2)

         X12 = X1 - X2
         Y12 = Y1 - Y2

         VOL = (X12 * (DY2 + DY1) - Y12 * (DX2 + DX1) + DX1 * DY2 -
     *      DX2 * DY1 ) / 2.0

         IF (AXI) THEN
            XC = (DX2 + DX1) / 4.0 + (X2 + X1) / 2.0
            VOL = 2.0 * PI * XC * VOL
         END IF

         DELVOL = DELVOL + VOL
  100 CONTINUE

      RETURN
      END


MODULE QR_mod
    IMPLICIT NONE
    PRIVATE
    PUBLIC:: makeQR
CONTAINS
    SUBROUTINE makeQR(m,n,A,Q,R)
        INTEGER(4)::m,n
        REAL(4),DIMENSION(:,:),INTENT(IN):: A
        REAL(4),DIMENSION(:,:),INTENT(OUT)::Q(m,m),R(m,n)
        REAL(4),ALLOCATABLE::H(:,:)
        REAL(4),ALLOCATABLE::Hp(:,:)
        INTEGER(4),ALLOCATABLE::diag(:,:)
        REAL(4),ALLOCATABLE::e(:)
        REAL(4),ALLOCATABLE::x(:)
        REAL(4),ALLOCATABLE::sigma(:)
        INTEGER(4):: i,ii,ij
        REAL(4),ALLOCATABLE::w(:,:)

        ALLOCATE(sigma(min(m-1,n)))
        ALLOCATE(H(m,m))
        R=A
        Q=0
        DO i=1,m
            Q(i,i)=1
        END DO
        DO i=1,min(m-1,n)
            IF (i==1) THEN      !the first step
                ALLOCATE(e(m))
                ALLOCATE(x(m))
                ALLOCATE(w(m,1))
                ALLOCATE(diag(m,m))
                diag=0
                DO ii=1,m
                    diag(ii,ii)=1
                END DO
                e=0
                e(1)=1
                x=A(1:m,1)
                sigma(1)=-sgn(R(1,1))*norm2(x)
                if(R(1,1)>=0) sigma(1)=-sigma(1)
                w(:,1)=x-sigma(1)*e
                H=diag-MATMUL(w,transpose(w))/(sigma(1)*(sigma(1)-R(1,1)))
                R=MATMUL(H,R)

                Q=MATMUL(Q,transpose(H))
                DEALLOCATE(e)
                DEALLOCATE(x)
                DEALLOCATE(w)
                DEALLOCATE(diag)
            END IF

            IF(i/=1) THEN      ! the Ith step
                ALLOCATE(e(m-i+1))
                ALLOCATE(x(m-i+1))
                ALLOCATE(w(m-i+1,1))
                ALLOCATE(diag(m-i+1,m-i+1))
                ALLOCATE(Hp(m-i+1,m-i+1))
                e=0
                e(1)=1
                x=R(i:m,i)
                sigma(i)=-sgn(R(i,i))*norm2(x)
                if(R(i,i)>=0) sigma(i)=-sigma(i)
                w(:,1)=x-sigma(i)*e
                diag=0
                DO ii=1,m-i+1
                    diag(ii,ii)=1
                END DO
                Hp=diag-MATMUL(w,transpose(w))/(sigma(i)*(sigma(i)-R(i,i)))
                H=0
                DO ii=1,i-1
                    H(ii,ii)=1
                END DO
                DO ii=i,m
                    DO ij=i,m
                        H(ii,ij)=Hp(ii-i+1,ij-i+1)
                    END DO
                END DO
                R=MATMUL(H,R)
                Q=MATMUL(Q,transpose(H))
                DEALLOCATE(e)
                DEALLOCATE(x)
                DEALLOCATE(w)
                DEALLOCATE(diag)
                DEALLOCATE(Hp)
            END IF
        END DO
    END SUBROUTINE makeQR
    FUNCTION sgn(x)
        REAL(4)::sgn
        REAL(4)::x
        if (x==0) sgn = 0
        if (x>0)  sgn = 1
        if (x<0)  sgn = -1
    END FUNCTION
END MODULE


!=====================================================|
subroutine cfl
!=====================================================|
  use geometry_def, only: dt,dx,margin,nxg,qq,cc
  use const_def, only: cv,gm,pi
  implicit none

  integer :: i
  real(KIND(0.d0)) :: pr ! gas pressure
  real(KIND(0.d0)) :: cs ! speed of sound
  real(KIND(0.d0)) :: vv ! total fluid velocity
  real(KIND(0.d0)) :: ca ! Alfven velocity
  real(KIND(0.d0)) :: safety = 0.5d0
!-----------------------------------------------------|
  dt = 1.d20

  do i = 1,nxg
     pr = qq(i,1)**gm*exp(qq(i,8)/cv)
     cs = sqrt(gm*pr/qq(i,1))
     vv = sqrt( qq(i,2)**2 + qq(i,3)**2 + qq(i,4)**2)
     ca = sqrt((qq(i,5)**2 + qq(i,6)**2 + qq(i,7)**2)/4.d0/pi/qq(i,1))

     cc(i) = cs + vv + ca
     dt = min(safety*dx/cc(i),dt)
     cc(i) = 1.d0*cc(i)
  enddo

  return
end subroutine cfl


      SUBROUTINE QUIKVIS5A2C1(IREQ,ANOMLY,BAR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE QUIKVIS PROGRAM.  IT IS USED TO LOAD THE
C 121-CHARACTER VARIABLE NAMED 'BAR' THAT IS USED TO DISPLAY TARGET
C AVAILABILITY FOR A SPECIFIC TIME, RAAN, AND OBSERVATION REQUIREMENT.
C THE BAR SHOWS THE AVAILABILITY MEAN ANOMALY RELATIVE TO THE ORBIT
C EVENT IDENTIFIED BY THE KRELTIME GLOBAL PARAMETER(IN QUIKVIS.INC).
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C IREQ      1   I*4  I  PRESENT FOR DEBUG USE ONLY.  THE OBSERVATION
C                       REQUIREMENT NUMBER(1=HORIZON, 2=NIGHT,...)
C                       INVOLVED ON THIS CALL.
C
C ANOMLY    2   R*8  I  RELATIVE MEAN ANOMALY RANGE WHERE THE CURRENT
C                       REQUIREMENT IS SATISFIED.  ANOMLY(1) IS THE
C                       START VALUE, ANOMLY(2) THE END VALUE.
C                       IN RADIANS.
C
C BAR       1 CH*121 O  121-CHARACTER STRING, EACH STRING ELEMENT BEING
C                       ASSOCIATED WITH A 3-DEGREE RANGE OF RELATIVE
C                       MEAN ANOMALY, THE FIRST ELEMENT REPRESENTING THE
C                       0-3 RANGE, THE SECOND THE 3-6 RANGE, ETC.  THE
C                       121-ST ELEMENT REPRESENTS THE 360 DEGREE VALUE.
C
C                       IF THE ELEMENT IS '*', THE REQUIREMENT IS
C                       SATISFIED IN THAT ELEMENT'S RANGE.  IF BLANK, IT
C                       IS NOT SATISFIED.
C
C***********************************************************************
C
C BY C PETRUZZO/GFSC/742.   2/86.
C       MODIFIED.... 9/86. CJP.  EXTENSIVE MODS TO MORE ACCURATELY FILL
C                                THE 121 PRINT POSITIONS;  PROBLEMS
C                                TENDED TO OCCUR WHEN 2PI WAS CROSSED;
C                                REPLACED TAREQ ARRAY WITH ANOMLY ARRAY;
C                                ADDED IREQ TO ARGUMENT LIST FOR DEBUG.
C
C***********************************************************************
C
      INCLUDE 'QUIKVIS.INC'
C
      REAL*8 ANOMLY(2)
      REAL*8 TOLER/0.D0/
      CHARACTER*121 BAR
      LOGICAL ALWAYS,NEVER
C
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,9001)
     *        IREQ,ANOMLY(1)*DEGRAD,ANOMLY(2)*DEGRAD
 9001 FORMAT(' QUIKVIS5A2C1.  IREQ=',I2,'  ANOMLY=',2G23.16)
C
C
C INITIALIZE
C
      ANOM1 = ANOMLY(1)
      ANOM2 = ANOMLY(2)
C
C
C ERROR CHECK. THIS ROUTINE IS CODED WITH THE EXPECTATION THAT
C ANOMLY(1) LT/EQ ANOMLY(2).  IF NOT, STOP TO FORCE A LOOK.
C
      IF(ANOM2.LT.ANOM1)
     *     STOP 'QUIKVIS5A2C1. CODING ERROR. STOP 1. SEE SOURCE.'
C
C
C SET THE TOLERANCE ANGLE USED TO DETERMINE WHETHER EXACTLY ZERO OR
C EXACTLY TWOPI IS INTENDED FOR THE ANOMLY INPUT VALUES.
C
      IF(TOLER.EQ.0.D0) THEN
        TOLER = (1.D0/3600.D0) / DEGRAD  ! = 1 ARC SEC
        TOLER2 = 2.D0 * TOLER  ! USED WHEN TESTING A SUM OR DIFFERENCE
        END IF
C
C
C ASSIGN 121 PRINT POSITIONS TO THE 360 DEGREE ANOMALY RANGE, THEN
C PUT *'S IN PRINT POSITIONS FOR THE ANOMALIES WHERE THE TARGET IS
C AVAILABLE.  ZERO AND 360 ARE EQUIVALENT, BUT USE TWO POSITIONS FOR
C EASIER READING.  THIS CODE WOULD BE SIMPLER IF WE DID NOT HAVE TO
C ACCOUNT FOR THE ROUNDING EFFECTS AT THE ZERO AND TWOPI POSITIONS.
C
      ALWAYS = DABS( (ANOM2-ANOM1)-TWOPI ) .LE. TOLER2
      NEVER =  ANOM2-ANOM1 .LE. TOLER2
C
      IF(ALWAYS) THEN
        ANOM1 = 0.D0
        ANOM2 = TWOPI
C
      ELSE IF(NEVER) THEN
        CONTINUE
C
      ELSE
        ANOM1 = EQVANG(ANOMLY(1))
        ANOM2 = EQVANG(ANOMLY(2))
C      ACCOUNT FOR POSSIBLE ROUNDING ERROR IN ANOM1.
        IF(ANOM1.LT.TOLER) THEN
          ANOM1 = 0.D0
        ELSE IF(DABS(ANOM1-TWOPI).LT.TOLER) THEN
          ANOM1 = 0.D0
          END IF
C      ACCOUNT FOR POSSIBLE ROUNDING ERROR IN ANOM2.
        IF(ANOM2.LT.TOLER) THEN
          ANOM2 = 0.D0
        ELSE IF(DABS(ANOM2-TWOPI).LT.TOLER) THEN
          ANOM2 = TWOPI
          END IF
C      BE SURE THE ANOM2 VALUE IS GREATER THAN THE ANOM1 VALUE.
        IF(ANOM2.LT.ANOM1) ANOM2 = ANOM2 + TWOPI
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,9002)
     *    ALWAYS,NEVER,ANOM1*DEGRAD,ANOM2*DEGRAD
 9002 FORMAT(' QUIKVIS5A2C1.  ALWAYS,NEVER=',2L2,
     *            '  ANOM1,ANOM2=',2G23.16)
C
      BAR = ' '
C
C    IF THE REQUIREMENT IS SATISFIED AT LEAST PART OF THE TIME, PUT *'S
C    IN THE APPROPRIATE POSITIONS IN THE BAR STRING.
      IF(.NOT.NEVER) THEN
        DELBAR =     TWOPI/120.D0
        K1 = (ANOM1+TOLER)/DELBAR + 1
        K2 = (ANOM2+TOLER)/DELBAR + 1
        IF(IBUG.NE.0) WRITE(LUBUG,9003) K1,K2,DELBAR*DEGRAD
 9003   FORMAT(' QUIKVIS5A2C1.  K1,K2=',2I4,'   DELBAR=',G23.16)
        DO I=K1,K2
          ICH = I
          IF(ICH.NE.121) THEN  ! POSITION 121 IS HANDLED LATER.
            IF(ICH.GT.120) ICH = ICH - 120
            BAR(ICH:ICH) = '*'
            END IF
          END DO
C      FOR BARS THAT END ON OR CROSS 2PI, MAKE SURE THE ZERO AND 2PI
C      POSITIONS ARE SET PROPERLY.
        IF(DABS(ANOM2-TWOPI).LT.TOLER) BAR(121:121) = '*'
        IF(ANOM2.GT.(TWOPI+TOLER)) THEN
          BAR(  1:  1) = '*'
          BAR(121:121) = '*'
          END IF
        END IF

      RETURN
C
C***********************************************************************
C
C
C**** INITIALIZATION CALL. PUT GLOBAL PARAMETER VALUES INTO THIS
C     ROUTINE'S LOCAL VARIABLES.
C
      ENTRY QVINIT5A2C1
C
      CALL QUIKVIS999(-1,R8DATA,I4DATA,L4DATA)
      RETURN
C
C***********************************************************************
C
      END


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine side3d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 1.2
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!  Latest Update: Feb. 22, 1994
!
!  PURPOSE  creates the parameter matrices required for the side cell
!           subdivisions of LAS3G.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!-----------------------------------------------------------------------------
      subroutine side3d(R,ir,B,ib,S,is,CS,AS,iout,tol)
      real CS(28,*), AS(18,7,*)
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RS(18,18), DA(18), BB(7,7)
      integer ic(18,6), indx(18)
      data ic/10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,      &
              4, 5, 6, 7, 8, 9,13,14,15,16,17,18,22,23,24,25,26,27,      &
              2, 3, 5, 6, 8, 9,11,12,14,15,17,18,20,21,23,24,26,27,      &
              1, 2, 4, 5, 7, 8,10,11,13,14,16,17,19,20,22,23,25,26,      &
              1, 2, 3, 4, 5, 6,10,11,12,13,14,15,19,20,21,22,23,24,      &
              1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18/

   1  format(a,a,a)
   2  format(a,e13.4)
!							for each side...
      do 70 ns = 1, 6
!							extract R
         do 10 j = 1, 18
            do 10 i = 1, j
               RS(i,j) = R(ic(i,ns), ic(j,ns))
  10     continue
!							factorize R
         call dsifa(RS,18,18,indx,ierr)
         if( ierr .ne. 0 ) then
            write(iout,1)'Error: unable to factorize side covariance matrix in SIDE3D.'
            stop
         endif
!							make a copy of S
         do 50 j = 1, 7
            do 20 i = 1, 18
               DA(i) = S(ic(i,ns),j)
  20        continue
!							and solve for A
            call dsisl(RS,18,18,indx,DA)
!							store in real*4
            do 30 i = 1, 18
               AS(i,j,ns) = DA(i)
  30        continue
!							update B
            do 40 i = 1, j
               BB(i,j) = B(i,j)
               do 40 k = 1, 18
                  BB(i,j) = BB(i,j) - S(ic(k,ns),i)*DA(k)
  40        continue
  50     continue
!							Cholesky Decomposition
         call dchol2( BB, 7, 7, rerr )
         if( rerr .gt. tol ) then
            write(iout,1)'Warning: Cholesky decomposition of side covariance matrix BB'
            write(iout,2)'         has maximum relative error of ',rerr
         endif
!							store in real*4
         ii = 0
         do 60 j = 1, 7
         do 60 i = 1, j
            ii = ii + 1
            CS(ii,ns) = BB(i,j)
  60     continue
  70  continue

      return
      end


MODULE fieldinfo_
 integer, parameter :: ni=256,nj=ni
 real, parameter ::  leni=300,lenj=leni
 real, parameter :: pi=3.14159265358979
 real, parameter :: rad1=leni/10800.*pi, rad2=rad1
 real, parameter :: amin2grid=float(ni)/leni
 character(3), parameter :: bkind="lin"
 real, parameter :: lmin=2.*pi/rad1*0.5
 real, parameter :: lmax=2.*pi/rad1*(ni/2)*1.
 integer, parameter :: npmax=50,npmax2=npmax*2,npmax3=npmax*3
 real, parameter :: rhoasec=30
 integer, parameter :: ntot=nint(rhoasec*leni*lenj)
 real, parameter :: intshear=0.22
 real :: lbin(npmax),dlbin(npmax),llowbin(npmax+1)
end module fieldinfo_


      real*8 function hscalc(f_l1,f_l2,vrr,eev,l,mesh,dx,rnot)

        USE param
      implicit none

      real*8 vrr(nrad),eev
      integer l
      real*8 res
      integer mesh
      real*8 dx,rnot

      real*8 f_l1(nrad),f_l2(nrad)
      real*8 mfield(nrad),rmesh(nrad),fint(nrad)
      real*8 dv(nrad)
      integer i

      do i = 1,mesh
         rmesh(i)  = rnot*exp((i-1)*dx)
         mfield(i) = 0.5d0+1.d0/(2.d0*(2.d0*clight)**2)* &
                      (eev-vrr(i))
      enddo

      call dergl2(vrr(1),dv(1),rnot,dx,mesh)

      do i=1,mesh
      fint(i)=dv(i)*f_l1(i)*f_l2(i)/(4.d0*mfield(i)**2*(2.d0*clight)**2)  &
              *2.d0/rmesh(i)
      enddo

      call cali(fint,res,rmesh(1),dx,mesh)
      hscalc=res
      return
      end


      Program TB0201

      Implicit None

*   Initial, Final Point
      Double Precision  xMin
      Parameter         (xMin = 0.0D0)
      Double Precision  xMax
      Parameter         (xMax = 3.0D0)
      Double Precision  yMin
      Parameter         (yMin = 1.0D0)
*   Data Dimension
      Integer           DNum
      Parameter         (DNum = 9)
*   Data Storage
      Integer           GridN(DNum)
      Double Precision  Gap(DNum), y1El(DNum), y3El(DNum), y1Ty(DNum),
     $                  y3Ty(DNum), y1Ip(DNum), y3Ip(DNum)
*   Dummy
      Integer           I
*   Function
      Double Precision  Func, Ext
      External          Func, Ext

      Open(11, File = 'Table-2-1.txt')
 1000 Format(F6.3,6F14.7)
 1010 Format(A6,6A14)
 1020 Format(A6,3A28)

*   Data Declaration
      Data GridN /6,15,30,60,150,300,600,1500,3000/
      Do 10 I = 1, DNum
        Gap(I) = (xMax - xMin) / DBLE(GridN(I))
  10  Continue

      Do 110 I = 1, DNum
        Call El(y1El(I), y3El(I), xMin, xMax, yMin, GridN(I), Gap(I))
        Call Ty(y1Ty(I), y3Ty(I), xMin, xMax, yMin, GridN(I), Gap(I))
        Call Ip(y1Ip(I), y3Ip(I), xMin, xMax, yMin, GridN(I), Gap(I))
  110 Continue

      Write(11,1020) '------', '----------------------------',
     $               '----------------------------',
     $               '----------------------------'
      Write(11,1020) ' ', 'Euler Method     ',
     $               'Taylor Series    ', 'Implicit Method   '
      Write(11,1020) ' ', 'Eq.(2.6)       ',
     $               'Eq.(2.10)      ', 'Eq.(2.18)      '
      Write(11,1010) 'h  ', 'y(1)  ', 'y(3)  ',  'y(1)  ',
     $               'y(3)  ', 'y(1)  ', 'y(3)  '
      Write(11,1020) '------', '----------------------------',
     $               '----------------------------',
     $               '----------------------------'
      Do 20 I = 1, DNum
        Write(11,1000) Gap(I), y1El(I), y3El(I), y1Ty(I), y3Ty(I),
     $                 y1Ip(I), y3Ip(I)
  20  Continue
      Write(11,1020) '------', '----------------------------',
     $               '----------------------------',
     $               '----------------------------'

      End Program TB0201

*-----------------------------------------------------------------------
*
      Subroutine El(y1, y3, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext
      External          Func, Ext

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        yn1 = yn0 + (xn1 - xn0) * Func(xn0,yn0)
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      End Subroutine El

*-----------------------------------------------------------------------
*
      Subroutine Ty(y1, y3, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext, FuncDx, FuncDy
      External          Func, Ext, FuncDx, FuncDy

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        yn1 = yn0 + (xn1 - xn0) * Func(xn0,yn0) + 0.5D0 * (xn1 - xn0) *
     $        (xn1 - xn0) * (FuncDx(xn0,yn0) + Func(xn0,yn0) *
     $        FuncDy(xn0,yn0))
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      End Subroutine Ty

*-----------------------------------------------------------------------
*
      Subroutine Ip(y1, y3, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext, FuncG
      External          Func, Ext, FuncG

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        yn1 = yn0 * (1.0D0 + 0.5D0 * (xn1 - xn0) * FuncG(xn0)) /
     $        (1.0D0 - 0.5D0 * (xn1 - xn0) * FuncG(xn1))
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      End Subroutine Ip

*-----------------------------------------------------------------------
*
      Function Func(x,y)

      Implicit None
      Double Precision  Func, x, y

      Func = - x * y

      End Function Func

*-----------------------------------------------------------------------
*
      Function FuncDx(x,y)

      Implicit None
      Double Precision  FuncDx, x, y

      FuncDx = - y

      End Function FuncDx

*-----------------------------------------------------------------------
*
      Function FuncDy(x,y)

      Implicit None
      Double Precision  FuncDy, x, y

      FuncDy = - x

      End Function FuncDy

*-----------------------------------------------------------------------
*
      Function FuncG(x)

      Implicit None
      Double Precision  FuncG, x

      FuncG = - x

      End Function FuncG

*-----------------------------------------------------------------------
*
      Function Ext(x)

      Implicit None
      Double Precision  Ext, x

      Ext = DExp(-x*x/2.0D0)

      End Function Ext


program black_hole_maps
  use mod_constants
  use mod_read_parameters
  use mod_maps

  implicit none

  integer, parameter :: nbT = 400
  integer, parameter :: nbS = 400

  real(x_precision), dimension(n_cell,nbT,nbS) :: Q_res   ! The Q+-Q- grids, one for each position in the disk
  real(x_precision), dimension(n_cell,nbT,nbS) :: tau_res ! The tau grids, one for each position in the disk

  call get_parameters()

  call set_conditions(nbS, nbT)

  call build_grid(Q_res, tau_res)

  call save_data(Q_res, tau_res)

end program black_hole_maps


C++***************************************************************
C Program to divide two bispectra
C
C JLP
C Version of 23-10-92
C--***************************************************************
	PROGRAM BISP_DIVIDE
	INTEGER*4 IN1,IN2,OUT,MADRID(1)
	CHARACTER NAME1*40,NAME2*40,NAME_OUT*40,COMMENTS*80
	COMMON /VMR/MADRID

C To get the possibility of command line
	CALL JLP_BEGIN

C Inquire the format (input/output) :
	CALL JLP_INQUIFMT

        PRINT 81
81	FORMAT(' Program BISP_DIVIDE to divide one bispectrum by another')

C Input :
        PRINT *,' First bispectrum:'
	NAME1=' '
	CALL JLP_VM_READIMAG(IN1,NX1,NY1,NAME1,COMMENTS)
C
        PRINT *,' Second bispectrum:'
	NAME2=' '
	CALL JLP_VM_READIMAG(IN2,NX2,NY2,NAME2,COMMENTS)

C Error handling:
        IF(NX1.NE.NX2)THEN
          PRINT *,' BISP_DIVIDE/Fatal error: incompatible sizes'
          CALL JLP_END
          STOP
        ENDIF

C Get memory space:
	ISIZE=NX1*NY1*4
	CALL JLP_GETVM(OUT,ISIZE)

C Processing
	CALL DIVIDE(MADRID(IN1),MADRID(IN2),MADRID(OUT),NX1,NY1)

C Output :
	WRITE(COMMENTS,84) NAME1(1:20),NAME2(1:20)
84	FORMAT(A20,' divided by ',A20)
	NAME_OUT=' '
	  CALL JLP_WRITEIMAG(MADRID(OUT),NX1,NY1,NX1,
     1	NAME_OUT,COMMENTS)

99	CALL JLP_END
	STOP
	END
C*********************************************************************
C To divide two complex:
C Real = Real1 * Real2 + Ima1 * Ima2
C Ima  = Ima1  * Real2 - Real1 * Ima2
C********************************************************************
	SUBROUTINE DIVIDE(IN1,IN2,OUT,NX1,NY1)
	INTEGER NX1,NY1
	INTEGER I,J
	REAL*4 IN1(NX1,*),IN2(NX1,*),OUT(NX1,*)

	DO I=1,NX1
          OUT(I,1)=IN1(I,1)*IN2(I,1)+IN1(I,2)*IN2(I,2)
          OUT(I,1)=IN1(I,2)*IN2(I,1)-IN1(I,1)*IN2(I,2)
        ENDDO

C Copy third line (SNR) if present
        IF(NY1.GE.3)THEN
           OUT(I,3)=IN1(I,3)
        ENDIF

	RETURN
	END


	subroutine srfestim(dx,dy,dz,R,scale)
c+++++++++++added by walter 1 Feb 2005
c definizione della funzione di area di una sfera intersecante un cubo.

	integer icont,sqrdim,identro,icontmax
      real dx,dy,dz,rho,rhoinv,deltateta,sindteta,fact,ca,cb,sa,sb
	real ll,passod,passoR,dmin,dmax,tetacen,phicen,deltaphi
	real alpha,beta,ii,x,y,z,rapp,area,acalotta,scale
	real pi,step,r1x,r1y,r1z,r2x,r2y,r3x,r3y,r3z,R

      pi=3.1416
	sqrdim=500
c     assumo lato cubo pari a 1
      ll=1./scale

c     rho= distanza tra centro cubo e centro sfera
      rho=sqrt(dx*dx+dy*dy+dz*dz)
      rhoinv=1./rho
c     teta scandisce la verticale e phi il piano xy
c     mi devo muovere in un intorno del cubetto
c     calcolo i parametri angolari del centro del cubetto
      tetacen=pi/2.
	phicen=0.
      deltaphi=1.3*ll*rhoinv
	deltateta=1.3*ll*rhoinv
      sindteta=sin(deltateta)
      fact=4*deltaphi*sindteta
c	 *sin(tetacen)
c      materiale per i cambiamenti di base

      if ((dx.eq.0.).and.(dy.eq.0.)) then
        alpha=0.
      else
        alpha=-asin(dy/sqrt(dx*dx+dy*dy))
      end if
      beta=-asin(dz*rhoinv)

      ca=cos(alpha)
	sa=sin(alpha)
      cb=cos(beta)
	sb=sin(beta)

	r1x=cb*ca
	r1y=cb*sa
	r1z=sb
	r2x=-sa
	r2y=ca
	r3x=-sb*ca
	r3y=-sb*sa
	r3z=cb

c     genero una griglia di valori a caso di cos(teta) e phi
      step=2./sqrdim
	icont=1
	identro=0
      do cteta=-sindteta,sindteta,step*sindteta
	   steta=sqrt(1.-cteta**2)
	   do phi=-deltaphi,deltaphi,step*deltaphi
	     icont=icont+1
c     ora devo vedere se x,y e z dello stesso punto sono compresi nel cubetto
           x=steta*(cos(phi)*r1x+sin(phi)*r1y)+cteta*r1z
	     if (abs(2.*(x*R-dx)).lt.ll) then
             y=steta*(cos(phi)*r2x+sin(phi)*r2y)
	       if (abs(2.*(y*R-dy)).lt.ll) then
               z=steta*(cos(phi)*r3x+sin(phi)*r3y)+cteta*r3z
	         if (abs(2.*(z*R-dz)).lt.ll) then
	           identro=identro+1
	         end if
	       end if
	     end if
         end do
	end do
      icontmax=icont-1

      rapp=float(identro)/icontmax
c      if(identro*1000.lt.icontmax) then
c        write(6,*) 'pochi per statistica',rapp
c      end if
c	 %*sin(tetacen)
      area=rapp*R*R*fact
	end