program create_image
  use gildas_def
  use image_def
  use gbl_format
  use gkernel_interfaces
  !---------------------------------------------------------------------
  !     CREATE_IMAGE:  Create an IMAGE
  !
  !     This task create an image which can be read
  !     from a file or created from a function.
  !     The ouput filename is  FILEO$.
  !
  !     A- From a FILE:  if the logical variable IFILE$ is set to YES
  !     an image is read from the input formatted file FILEI$
  !     the column must ordered as :  x y z
  !     and expect standard gdf image structure
  !     For convenience, z should be in Brightness temperature as for B case.
  !
  !     B- From a FUNCTION: If one of the function is activated a
  !     corresponding image using the parameters PARAMETERS$ will be created.
  !     Intensity are in Brightness temperature.
  !
  !     1- Elliptical Disk             (E_DISK)
  !     2- Elliptical Ring             (E_RING)
  !     3- Elliptical Gaussian         (E_GAUS)
  !     6- Elliptical Exponential      (E_EXPO)
  !     4- Rectangle                   (RECT)
  !     5- Power law                   (POW)
  !     7- plan                        (PLAN)
  !
  !     Convertion to Jansky is possible if variable JANSKY$ is set to YES.
  !     The image can be mutiplied by a gaussian beam if BEAM$ is set to YES
  !     parameters are similar as for function GAUSS.
  !
  !     ONLY ONE function can be computed at the same time,
  !     Nevertheless more complex images can be produced using both
  !     CIMAGE and COMBINE tasks.
  !
  !     The 7 input  parameters are :
  !     E_DISK,E_GAUSS,E_EXPO,RECT,PLAN
  !     1,2     X,Y center relative coordinates (")
  !     3       Brightness Temperature (K)
  !     4       Position angle of the source (in DEGREES) , western direction
  !     5,6     Major and Minor axis (")
  !     7       NOT USED
  !
  !     E_RING
  !     1,2     X,Y center relative coordinates (")
  !     3       Brightness Temperature (K)
  !     4       Position angle of the source (in DEGREES)
  !     5,6     inner and outer equatorial radius (")
  !     7       FLATTENING FACTOR (RPOL/REQU)
  !
  !     FOR POW
  !     1,2     X,Y center relative coordinates (")
  !     3       Brightness Temperature (K)
  !     4       A: distance threshold  (")
  !     5       B: power
  !     6       not used
  !     7       NOT USED
  !
  !     FOR PLAN
  !     1,2     X,Y center relative coordinates (")
  !     3       Brightness Temperature (K)
  !     4       Position angle of the source (in DEGREES)
  !     5,6     A,B COEFFICIENT OF THE PLAN EQUATION (1/")
  !     7       NOT USED
  !
  !     R.Moreno & E.Dartois
  !     1st  version 08-Mar-2000
  !     last version 18-Nov-2003
  !---------------------------------------------------------------------
  ! Local
  logical :: error
  character(len=filename_length) :: filei,fileo
  character(len=16) :: linename,sourcename
  integer(kind=4) :: nx,ny,nv,nxyv(3)
  real(kind=8) :: size
  real(kind=8) :: xstep,ystep
  real(kind=8) :: frequency,fstep,vstep
  logical :: ifile,e_disk,e_ring,e_gaus,recta,pow,expo,beam,jansky,plan
  real(kind=8) :: param(7),pbeam(7)
  real(kind=8) :: clight
  real(kind=8) :: pi,arc
  integer(kind=4) :: ok,n,ier
  type(gildas) :: x
  !
  !     Initialisations
  !
  call gildas_open
  call gildas_logi('IFILE$',ifile,1)
  call gildas_char('FILEI$',filei)
  call gildas_char('FILEO$',fileo)
  call gildas_inte('NXYV$',nxyv,3)
  !
  call gildas_dble('SIZE$',size,1)
  call gildas_char('SOURCE$',sourcename)
  call gildas_char('LINE$',linename)
  call gildas_dble('FREQUENCY$',frequency,1)
  call gildas_dble('DF$',fstep,1)
  !
  call gildas_logi('E_DISK$',e_disk,1)
  call gildas_logi('E_RING$',e_ring,1)
  call gildas_logi('E_GAUS$',e_gaus,1)
  call gildas_logi('E_EXPO$',expo,1)
  call gildas_logi('RECT$',recta,1)
  call gildas_logi('POW$',pow,1)
  call gildas_logi('PLAN$',plan,1)
  call gildas_dble('PARAMETERS$',param,7)
  call gildas_logi('JANSKY$',jansky,1)
  call gildas_logi('BEAM$',beam,1)
  call gildas_dble('PARAMETERS2$',pbeam,7)
  !
  call gildas_close
  !
  call gildas_null(x)
  nx = nxyv(1)
  ny = nxyv(2)
  nv = nxyv(3)
  !     NZ = NXYV(4)
  !
  !     CONSTANTS
  !
  pi = 3.14159265358979323846d0
  arc = 1.0d0/(180.0d0*3600.0d0/pi)
  clight = 299792458.d0        ! LIGHT SPEED         (m/s)
  !
  xstep = size/nx*arc          ! IMAGE STEP IN X     (rad)
  ystep = size/ny*arc          ! IMAGE STEP IN Y     (rad)
  frequency = frequency*1d6   ! FREQUENCY           (Hz)
  vstep = -fstep*clight/frequency*1.d3    ! VELOCITY RESOLUTION (Km/s)
  !
  n = len_trim(fileo)
  if (n.eq.0) goto 100
  !
  call gildas_null(x)
  call sic_parsef(fileo,x%file,' ','.gdf')
  x%gil%ndim = 3
  x%gil%dim(1) = nx
  x%gil%dim(2) = ny
  x%gil%dim(3) = nv
  x%gil%dim(4) = 1
  x%gil%ref(1) = nx/2+1
  x%gil%val(1) = 0.d0
  x%gil%inc(1) = -xstep            ! assume RA  coordinate
  x%gil%ref(2) = ny/2+1
  x%gil%val(2) = 0.d0
  x%gil%inc(2) = ystep             ! assume Dec coordinate
  x%gil%ref(3) = nv/2
  x%gil%val(3) = 0.d0
  x%gil%inc(3) = vstep
  x%gil%extr_words = 0
  !
  x%char%syst = 'EQUATORIAL'
  x%char%name = sourcename
  x%gil%ra = 0.0d0
  x%gil%dec = 0.0d0
  x%gil%epoc = 2000.0
  x%gil%ptyp = p_azimuthal
  x%gil%a0 = x%gil%ra
  x%gil%d0 = x%gil%dec
  x%gil%pang = 0.0d0
  x%gil%xaxi = 1
  x%gil%yaxi = 2
  !
  x%char%unit = 'KELVIN'
  if (jansky) then
    x%char%unit = 'Jy'
  endif
  x%char%code(1) = 'RA'
  x%char%code(2) = 'DEC'
  x%char%code(3) = 'FREQUENCY'
  !
  x%char%line = linename
  x%gil%fres = fstep             ! in MHz
  x%gil%fima = 0.0d0
  x%gil%freq = frequency*1d-6    ! in MHz
  x%gil%vres = real(vstep)       ! in Km/s
  x%gil%voff = 0.0
  x%gil%faxi = 3
  !
  allocate (x%r3d(nx,ny,nv), stat=ier)
  x%r3d = 0.0
  !
  ok = 0
  if (ifile) then
    n = len_trim(filei)
    if (n.gt.0) then
      call lecture (nx,ny,nv,x%r3d,x%gil%convert,filei)
      ok = 1
    else
      write(*,*) ' '
      write(*,*) 'E-IMAGE: NO INPUT FILE '
      write(*,*) ' '
    endif
  endif
  if (e_disk) then
    if (ok.eq.0) then
      if ( (param(5).gt.0).and.(param(6).gt.0) ) then
        call edisk(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER 5 OR 6  < OR = 0'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*)   &
   &          'W-IMAGE: DISK NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (e_ring) then
    if (ok.eq.0) then
      if ( (param(5).gt.0).and.(param(6).gt.0).and.   &
   &          (param(7).gt.0).and.(param(5).le.param(6)) ) then
        call ering(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER 5,6,7 < OR = 0'
        write(*,*) 'E-IMAGE: PARAM(5) must be <  PARAM(6)'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*)   &
   &          'W-IMAGE: RING NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (e_gaus) then
    if (ok.eq.0) then
      if ( (param(5).gt.0).and.(param(6).gt.0) ) then
        call egaus(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER 5,6 < OR = 0'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*)   &
   &          'W-IMAGE: GAUSS NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (expo) then
    if (ok.eq.0) then
      if ( (param(5).gt.0).and.(param(6).gt.0).and.   &
   &          (param(7).gt.0) ) then
        call expo2(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER  5,6,7 < OR = 0'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*) 'W-IMAGE: EXP NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (recta) then
    if (ok.eq.0) then
      if ( (param(5).gt.0).and.(param(6).gt.0) ) then
        call rect2(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER 5,6 < OR = 0'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*)   &
   &          'W-IMAGE: RECT NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (pow) then
    if (ok.eq.0) then
      if ( (param(4).gt.0).and.(param(5).gt.0) ) then
        call pow2(nx,ny,nv,x%r3d,x%gil%convert,param)
        ok = 1
      else
        write(*,*) ' '
        write(*,*) 'E-IMAGE: PARAMETER 4,5 < OR = 0'
        write(*,*) ' '
      endif
    else
      write(*,*) ' '
      write(*,*) 'W-IMAGE: POW NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (plan) then
    if (ok.eq.0) then
      call plan2(nx,ny,nv,x%r3d,x%gil%convert,param)
      ok = 1
    else
      write(*,*) ' '
      write(*,*) 'W-IMAGE: EXP NOT COMPUTED: Only one function'
      write(*,*) ' '
    endif
  endif
  if (jansky) then
    call planck(nx,ny,nv,x%r3d,x%gil%convert,frequency)
  endif
  if (beam) then
    if ( (pbeam(5).gt.0).or.(pbeam(6).gt.0) ) then
      call ebeam(nx,ny,nv,x%r3d,x%gil%convert,pbeam,jansky)
    else
      write(*,*) ' '
      write(*,*) 'E-IMAGE: PARAMETER 5,6 < OR = 0'
      write(*,*) ' '
    endif
  endif
  !
  call gdf_write_image(x,x%r3d,error)
  if (error) goto 100
  call sysexi(1)
  !
  100 call sysexi(fatale)
  !
end program create_image
!
subroutine zini (x,n,t)
  integer(kind=4) :: n                      !
  real(kind=4) :: x(n)                      !
  real(kind=4) :: t                         !
  ! Local
  integer(kind=4) :: i
  do i=1,n
    x(i) = t
  enddo
end subroutine zini
!
subroutine lecture(nxx,nyy,nvv,val,convert,fileii)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  !
  !---------------------------------------------------------------------
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) :: convert(9)             !
  character(len=80) :: fileii       !
  ! Local
  real(kind=8) ::  xf,yf,zf
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc,vref,vval,vinc
  real(kind=8) ::  val_x,val_y,val_v,val_z
  logical :: error
  integer(kind=4) :: lch
  integer(kind=4) :: p_lun, ier
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  vref = convert(7)
  vval = convert(8)
  vinc = convert(9)
  !
  lch = lenc(fileii)
  ier = sic_getlun(p_lun)
  ier = sic_open(p_lun,fileii(1:lch),'OLD',.true.)
  if (ier.ne.0) then
    call gagout('W-CIMAGE, Cannot open file '//fileii(1:lch))
    call putios ('        ',ier)
    error = .true.
    call sic_frelun(p_lun)
  else
    do k=1,nvv
      do i=1,nxx
        do j=1,nyy
          read(p_lun,*) xf,yf,zf
          val_x = (i-xref)*xinc+xval
          val_y = (j-yref)*yinc+yval
          val_v = (k-vref)*vinc+vval
          val_z = zf
          val(i,j,k) = val(i,j,k)+val_z
        enddo
      enddo
    enddo
    close(unit=p_lun)
    call sic_frelun(p_lun)
  endif
end subroutine lecture
!
subroutine edisk(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: disk_e
  ! Local
  !     no choice val is real.
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = disk_e(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine edisk
!
function disk_e(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing a 2D ellipse
  !     f(x,y)=> (x/a)^2+(y/b)^2<=1
  !
  !     6 parameters (x0, y0, tb, theta, a, b)
  !---------------------------------------------------------------------
  real(kind=8) :: disk_e                  !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: dist
  real(kind=8) :: x0,y0,tb,theta,a,b
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  !
  pi=3.14159265358979323846
  arc = 1.0/(180.0*3600.0/pi)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)*0.5*arc         ! HALF BIG AXIS                (RAD)
  b=paramet(6)*0.5*arc         ! HALF SMALL AXIS              (RAD)
  !
  !     PARAMET(7) NOT USED
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     ELLIPTICAL DISK
  !
  dist=(xr/a)**2+(yr/b)**2
  if (dist.le.1.0) then
    disk_e=tb
  else
    disk_e=0.0
  endif
end function disk_e
!
subroutine ering(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: ring_e
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = ring_e(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine ering
!
function ring_e(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing a elliptical RING
  !     f(x,y)=> (x/a)^2+(y/(a*e))^2<=1 ; (x/b)^2+(y/(b*e))^2<=1
  !
  !
  !     7 parameters (x0, y0, tb, THETA, a, b, e)
  !---------------------------------------------------------------------
  real(kind=8) :: ring_e                  !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: dist_ext,dist_int
  real(kind=8) :: x0,y0,tb,theta,a,b,e
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)*0.5*arc         ! HALF EQUATORIAL INNER RING   (RAD)
  b=paramet(6)*0.5*arc         ! HALF EQUATORIAL OUTER RING   (RAD)
  e=paramet(7)                 ! FLATTENING FACTOR (RPOL/REQU) ---
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     ELLIPTICAL DISK
  !
  dist_int=(xr/a)**2+(yr/(a*e))**2
  dist_ext=(xr/b)**2+(yr/(b*e))**2
  if ( (dist_ext.le.1.0).and.(dist_int.ge.1.0) ) then
    ring_e=tb
  else
    ring_e=0.0
  endif
end function ring_e
!
subroutine egaus(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: gauss_e
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = gauss_e(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine egaus
!
function gauss_e(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing elliptical 2D Gaussian
  !     f(x,y)=Tb*exp(-4ln2*[(x/a)^2+(y/b)^2])
  !
  !     6 parameters (x0, y0, tb, theta, a, b)
  !---------------------------------------------------------------------
  real(kind=8) :: gauss_e                 !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: dist
  real(kind=8) :: x0,y0,tb,theta,a,b
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)*arc             ! HPBW IN X                    (RAD)
  b=paramet(6)*arc             ! HPBW IN Y                    (RAD)
  !
  !     PARAMET(7) NOT USED
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     ELLIPTICAL GAUSSIAN
  !
  dist=(xr/a)**2+(yr/b)**2
  gauss_e = tb*exp(-4.0*log(2.0)*dist)
end function gauss_e
!
subroutine rect2(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: rect3
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = rect3(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine rect2
!
function rect3(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing a rectangle
  !     f(x,y)=Tb  for  -a/2 < x < a/2
  !     and  -b/2 < x < b/2
  !     6 parameters (x0, y0, tb, theta, a, b)
  !---------------------------------------------------------------------
  real(kind=8) :: rect3                   !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: x0,y0,tb,theta,a,b
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  real(kind=8) :: xmin,xmax,ymin,ymax
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)*arc*0.5         ! HALF LENGHT IN X             (RAD)
  b=paramet(6)*arc*0.5         ! HALF LENGHT IN Y             (RAD)
  !
  !     PARAMET(7) NOT USED
  !
  ct=cos(theta)
  st=sin(theta)
  xmin=-a
  xmax=+a
  ymin=-b
  ymax=+b
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     RECTANGLE
  !
  if ( (xr.ge.xmin).and.(xr.le.xmax).and.   &
     &    (yr.ge.ymin).and.(yr.le.ymax)      ) then
    rect3=tb
  else
    rect3=0.0
  endif
end function rect3
!
subroutine pow2(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: pow3
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = pow3(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine pow2
!
function pow3(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing a power function of the radius
  !     f(r)=TB*(r/b)^c;
  !     a: r distance threshold  f(r<a)=f(a)
  !     B: WIDTH
  !     TB: VALUE AT R=B
  !     in order to exclude division by 0.0 when b=-1
  !     6 parameters (x0, y0, TB, a, b, c )
  !---------------------------------------------------------------------
  real(kind=8) :: pow3                    !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: x0,y0,tb,a,b,c
  real(kind=8) :: arc,pi
  real(kind=8) :: rmin,radius
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  a=paramet(4)*arc             ! DISTANCE THRESHOLD IN R      (RAD)
  b=paramet(5)*arc             ! WIDTH                        (RAD)
  c=paramet(6)                 ! POWER IN R                    --
  !
  !     PARAMET 7 NOT USED
  !
  rmin=abs(a)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     POWER
  !
  radius=sqrt(x1**2+y1**2)
  if (radius.ge.rmin) then
    pow3=tb*(radius/b)**c
  else
    pow3=tb*(rmin/b)**c
  endif
end function pow3
!
subroutine expo2(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: expo3
  ! Local
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = expo3(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine expo2
!
function expo3(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing an exponantial decreasing function of the radius
  !     F(r)=TB*EXP(-2^C.log2.0*[(x/a)^c+(y/b)^c]) ;
  !     7 parameters (x0, y0, TB, theta, a, b, c)
  !---------------------------------------------------------------------
  real(kind=8) :: expo3                    !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: radius
  real(kind=8) :: x0,y0,tb,theta,a,b,c
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)*arc             ! HPBW IN X                    (RAD)
  b=paramet(6)*arc             ! HPBW IN Y                    (RAD)
  c=paramet(7)                 ! POWER IN R
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     EXPONENTIAL
  !
  radius=sqrt((xr/a)**2+(yr/b)**2)
  expo3=tb*exp(-(2.0**c)*log(2.0)*radius**c)
end function expo3
!
subroutine plan2(nxx,nyy,nvv,val,convert,parame)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: parame(7)               !
  ! Global
  real(kind=8), external :: plan3
  ! Local
  !     no choice val is real.
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = plan3(val_x,val_y,parame)
        val(i,j,k) = val(i,j,k)+real(val_z)
      enddo
    enddo
  enddo
end subroutine plan2
!
function plan3(x1,y1,paramet)
  !---------------------------------------------------------------------
  !     Function computing a 2D PLAN
  !     f(x,y)=> ax+by+tb
  !
  !     6 parameters (x0, y0, tb, theta, a, b)
  !---------------------------------------------------------------------
  real(kind=8) :: plan3                   !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet(7)              !
  ! Local
  real(kind=8) :: x0,y0,tb,theta,a,b
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet(1)*arc            ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet(2)*arc            ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet(3)                ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet(4)*pi/180.     ! INCLINATION ANGLE            (RAD)
  a=paramet(5)/arc             ! A COEFFICIENT                (RAD^-1)
  b=paramet(6)/arc             ! B COEFFICIENT                (RAD^-1)
  !
  !     PARAMET(7) NOT USED
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     ELLIPTICAL DISK
  !
  plan3=a*xr+b*yr+tb
end function plan3
!
subroutine ebeam(nxx,nyy,nvv,val,convert,paramb,jansky)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: paramb(6)               !
  logical :: jansky                 !
  ! Global
  real(kind=8), external :: beam_e
  ! Local
  real(kind=8) :: fluxbeam
  integer(kind=4) :: i,j,k
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  fluxbeam=0.0
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        val_z = beam_e(val_x,val_y,paramb,jansky,xinc,yinc)
        val(i,j,k) = val(i,j,k)*real(val_z)
        fluxbeam=fluxbeam+val(i,j,k)
      enddo
    enddo
  enddo
  !
  if (jansky) then
    write(*,*) 'FLUX/BEAM  : ',real(fluxbeam/nvv),' Jy'
  else
    write(*,*) 'TMB : ',real(fluxbeam/nvv),' K'
  endif
end subroutine ebeam
!
function beam_e(x1,y1,paramet2,jansky,xinc,yinc)
  !---------------------------------------------------------------------
  !     Function computing elliptical 2D Gaussian beam attenuation
  !     f(x,y)=Tb*K*exp(-4ln2*[(x/a)^2+(y/b)^2])
  !     K is function of the unity (K, Jy)
  !
  !     6 parameters (x0, y0, tb, theta, a, b)
  !---------------------------------------------------------------------
  real(kind=8) :: beam_e                  !
  real(kind=8) :: x1                      !
  real(kind=8) :: y1                      !
  real(kind=8) :: paramet2(6)             !
  logical :: jansky                  !
  real(kind=8) :: xinc                    !
  real(kind=8) :: yinc                    !
  ! Local
  real(kind=8) :: dist
  real(kind=8) :: x0,y0,tb,theta,a,b,sa,sb
  real(kind=8) :: xr,yr,ct,st
  real(kind=8) :: arc,pi
  real(kind=8) :: sstep
  !
  pi=3.14159265358979323846d0
  arc = pi/(180.0d0*3600.0d0)
  !
  x0=paramet2(1)*arc           ! X RELATIVE CENTER COORDINATE (RAD)
  y0=paramet2(2)*arc           ! Y RELATIVE CENTER COORDINATE (RAD)
  tb=paramet2(3)               ! BRIGHTNESS TEMPERATURE        (K)
  theta=paramet2(4)*pi/180.    ! INCLINATION ANGLE            (RAD)
  a=paramet2(5)*arc            ! HPBW IN X                    (RAD)
  b=paramet2(6)*arc            ! HPBW IN Y                    (RAD)
  !
  !     PARAMET 7 NOT USED
  !
  sstep=xinc*yinc              ! PIXEL SIZE                   (STE)
  !
  ct=cos(theta)
  st=sin(theta)
  !
  !     TRANSLATION
  !
  x1=x1-x0
  y1=y1-y0
  !
  !     ROTATION
  !
  xr=x1*ct+y1*st
  yr=y1*ct-x1*st
  !
  !     ELLIPTICAL GAUSSIAN
  !
  sa=(a/2.0)/(sqrt(2.0*log(2.0)))
  sb=(b/2.0)/(sqrt(2.0*log(2.0)))
  dist=(xr/sa)**2+(yr/sb)**2
  if (jansky) then
    beam_e=tb*exp(-0.5*dist)
  else
    beam_e=tb*sstep/(2.0*pi*sa*sb)*exp(-0.5*dist)
  endif
end function beam_e
!
subroutine planck(nxx,nyy,nvv,val,convert,freq)
  integer(kind=4) :: nxx                    !
  integer(kind=4) :: nyy                    !
  integer(kind=4) :: nvv                    !
  real(kind=4) :: val(nxx,nyy,nvv)          !
  real(kind=8) ::  convert(6)               !
  real(kind=8) :: freq                    !
  ! Global
  real(kind=8), external :: planck2
  ! Local
  real(kind=4) :: temp,fluxtot,tmin
  integer(kind=4) :: i,j,k,temp0
  real(kind=8) ::  xref,xval,xinc,yref,yval,yinc
  real(kind=8) ::  val_x,val_y,val_z
  !
  freq = freq*1.0d-09
  !
  xref = convert(1)
  xval = convert(2)
  xinc = convert(3)
  yref = convert(4)
  yval = convert(5)
  yinc = convert(6)
  !
  fluxtot = 0.0
  temp0=0
  tmin=0.01
  !
  do i=1,nxx
    do j=1,nyy
      do k=1,nvv
        val_x = (i-xref)*xinc+xval
        val_y = (j-yref)*yinc+yval
        temp = val(i,j,k)
        if ( (temp.le.tmin).and.(temp.ne.0.0) ) then
          temp=0.0
          temp0=temp0+1
        end if
        val_z = planck2(freq,xinc,yinc,temp)
        val(i,j,k) = real(val_z)
        fluxtot = fluxtot+val(i,j,k)
      enddo
    enddo
  enddo
  !
  write(*,*) 'TOTAL FLUX : ',real(fluxtot/nvv),' Jy'
  if (temp0.gt.0) then
    write(*,*)   &
     &      'APPROXIMATION T<0.01K TO T=0 K, DONE ',temp0,' TIMES'
  end if
end subroutine planck
!
function planck2(nu,dx,dy,t)
  !---------------------------------------------------------------------
  !     This function compute the flux (Jy) per pixel
  !     using the planck law.
  !     frequency nu is in GHz.
  !---------------------------------------------------------------------
  real(kind=8) :: planck2                 !
  ! Local
  real(kind=8) :: hnuk,hnu3c2,jy,hnu3c2jy
  parameter(hnuk=4.799274d-2,hnu3c2=7.372615d-24,jy=1.0d-26,   &
            hnu3c2jy=7.372615d2)
  !
  real(kind=8) :: nu,asp,tb,f,dx,dy
  real(kind=4) :: t
  !
  if (t.gt.0.0) then
    tb=dble(t)
    !
    !     Flux of the planck function in Jy  (1.0e-26 Watt/m^2/Hz)
    !
    f=(2.0*hnu3c2jy*nu**3)/(exp(hnuk*nu/tb)-1.0)
    !
    !     solide angle of a  pixel in arcsec**2
    !
    asp=abs(dx*dy)
    !
    !     flux per pixel
    !
    planck2=f*asp
    !
  else
    planck2=0.0
  endif
end function planck2
