module peeled_images

  use core_lib
  use mpi_core
  use mpi_hdf5_io

  use grid_geometry, only : place_in_cell
  use grid_propagate

  use type_image
  use type_photon

  use sources
  use dust_main
  use dust_interact

  use grid_mrw

  implicit none
  save

  private

  public :: peeled_images_adjust_scale
  public :: peeled_images_setup
  public :: peeled_images_write
  public :: peeloff_photon
  public :: a_peeloff

  logical,public :: make_peeled_images

  integer,public :: n_groups = 0
  integer,public :: n_peeled = 0
  ! number of directions

  integer,allocatable :: group_id(:)
  integer,allocatable :: view_id(:)

  logical,allocatable :: inside_observer(:)
  logical,allocatable :: ignore_optical_depth(:)
  type(vector3d_dp), allocatable :: r_peeloff(:)
  type(angle3d_dp), allocatable :: viewing_angles(:)
  ! angles in which to make peeled images

  type(image),allocatable,public :: peeled_image(:)
  ! the peeled images

  type(image),allocatable,dimension(:),public :: peeled_image_sum

  real(dp),allocatable :: d_min(:), d_max(:)
  ! the distance range within which to peeloff photons for each group

  real(dp),allocatable :: column_density(:)

contains

  subroutine peeled_images_adjust_scale(scale)
    implicit none
    real(dp),intent(in) :: scale
    integer :: ig
    do ig=1,n_groups
       call image_scale(peeled_image(ig), scale)
    end do
  end subroutine peeled_images_adjust_scale

  subroutine peeloff_photon(p_orig, polychromatic)

    implicit none

    type(photon),intent(in) :: p_orig
    type(photon) :: p
    real(dp) :: tau
    integer :: ip,ig,iv
    type(angle3d_dp) :: a_req, a_sky, a_diff
    type(vector3d_dp) :: v_req
    logical,intent(in) :: polychromatic
    real(dp) :: x_image, y_image
    real(dp) :: tmax
    type(vector3d_dp) :: dr
    real(dp) :: d
    logical :: killed

    do ip=1,n_peeled

       ig = group_id(ip)
       iv = view_id(ip)

       p = p_orig

       ! Set photon properties to pre-interaction (except frequency)
       p%s = p%s_prev
       p%a = p%a_prev
       p%v = p%v_prev

       ! Find peeloff angle
       a_req = a_peeloff(p%r, ip)
       call angle3d_to_vector3d(a_req, v_req)

       ! Find peeloff probability
       if(p%last_isotropic) then
          p%s = stokes_dp(1._dp, 0._dp, 0._dp, 0._dp)
          p%a = a_req
          p%v = v_req
       else
          select case(p%last)
          case('sr')
             call emit_peeloff(p, a_req)
          case('ds','de')
             call interact_peeloff(p, a_req)
          case('me')
             call mrw_peeloff(p, a_req)
          case default
             call error("peeloff_photon","unexpected p%last flag: "//p%last)
          end select
       end if

       ! Update wall and cell that photon is on, because when the direction
       ! of the photon changes, the cell and wall it might be considered on
       ! may change. For example, if a photon is propagaging in the positive x
       ! direction and is in cell 2 on the xmin wall, but gets peeled off in
       ! the negative direction, we need to treat it as if it was in cell 1 on
       ! the xmax wall.
       call place_in_cell(p)

       if(inside_observer(ig)) then
          dr = p%r-r_peeloff(ig)
          d = sqrt(dr.dot.dr)
          tmax = d - d_min(ig)
       else
          d = -(v_req.dot.p%r)
          tmax = - d_min(ig) + d
       end if

       if(d < d_min(ig) .or. d > d_max(ig)) cycle

       if(inside_observer(ig)) then

          if(abs(viewing_angles(ip)%cost) .gt. 1.e-10) then
             call rotate_angle3d(viewing_angles(ip), angle3d_deg(90._dp, 0._dp), a_diff)
             call difference_angle3d(a_diff, -p%a, a_sky)
          else
             a_sky = p%a
          end if

          ! Convert to angles in degrees
          x_image = atan2(a_sky%sinp, a_sky%cosp) * rad2deg
          y_image = atan2(a_sky%sint, a_sky%cost) * rad2deg - 90._dp

          ! Make sure the photon falls inside the image (wrap angles around)
          x_image = peeled_image(ig)%x_max + modulo(x_image - peeled_image(ig)%x_max, 360._dp)
          y_image = peeled_image(ig)%y_min + modulo(y_image - peeled_image(ig)%y_min, 360._dp)

       else

          ! Project onto 2-D plane perpendicular to direction of peeling-off
          dr = p%r - r_peeloff(ig)
          x_image = dr%y * p%a%cosp - dr%x * p%a%sinp
          y_image = dr%z * p%a%sint - dr%y * p%a%cost * p%a%sinp - dr%x * p%a%cost * p%a%cosp

       end if

       if(in_image(peeled_image(ig),x_image, y_image)) then

          if(ignore_optical_depth(ig)) then
             if(polychromatic) then
                column_density = 0._dp
             else
                tau = 0._dp
             end if
             killed = .false.
          else
             if(polychromatic) then
                call grid_escape_column_density(p,tmax,column_density,killed)
             else
                call grid_escape_tau(p,tmax,tau,killed)
             end if
          end if

          ! For inside observer, don't want optical depth to escape grid, just to go to observer!
          ! Need to include 1/d^2!

          if(.not.killed) then

             if(inside_observer(ig)) p%s = p%s / (4._dp * pi * tmax**2._dp)

             if(polychromatic) then
                call image_bin_raytraced(peeled_image(ig),p,x_image,y_image,iv,column_density)
             else
                p%s = p%s * exp(-tau)
                call image_bin(peeled_image(ig),p,x_image,y_image,iv)
             end if

          end if

       end if

    end do

  end subroutine peeloff_photon

  subroutine peeled_images_setup(handle, paths, use_raytracing, use_exact_nu, frequencies)

    implicit none

    integer(hid_t),intent(in) :: handle
    character(len=*),intent(in) :: paths(:)

    real(dp),intent(in),optional :: frequencies(:)

    logical,intent(in) :: use_raytracing, use_exact_nu

    integer :: ig,id,iv,is,ip = 0

    integer :: n_view

    ! real(dp) :: array_size = 0.

    real(dp),allocatable :: theta(:), phi(:)

    n_groups = size(paths)

    allocate(peeled_image(n_groups))
    allocate(peeled_image_sum(n_groups))
    if(main_process()) write(*,'(" [peeled_images] setting up ",I0," peeled image groups ")') n_groups

    allocate(inside_observer(n_groups))
    allocate(ignore_optical_depth(n_groups))
    allocate(r_peeloff(n_groups))
    allocate(d_min(n_groups))
    allocate(d_max(n_groups))

    ! Find total number of viewing angles
    n_peeled = 0
    do ig=1,n_groups
       call mp_read_keyword(handle, paths(ig), 'inside_observer', inside_observer(ig))
       call mp_read_keyword(handle, paths(ig), 'ignore_optical_depth', ignore_optical_depth(ig))
       call mp_read_keyword(handle, paths(ig), 'n_view', n_view)
       if(.not. n_view > 0) call error("n_view should be a positive integer", "peeled_images_setup")
       call mp_read_keyword(handle, paths(ig), 'd_min', d_min(ig))
       call mp_read_keyword(handle, paths(ig), 'd_max', d_max(ig))
       if(inside_observer(ig).and.d_min(ig) < 0.) then
          if(main_process()) call warn("d_min cannot be < 0. for inside observer - resetting to 0", "peeled_images_setup")
          d_min(ig) = 0.
       end if
       n_peeled = n_peeled + n_view
    end do

    allocate(group_id(n_peeled))
    allocate(view_id(n_peeled))
    allocate(viewing_angles(n_peeled))

    ip = 0

    do ig=1,n_groups

       if(inside_observer(ig)) then
          call mp_read_keyword(handle, paths(ig), 'observer_x', r_peeloff(ig)%x)
          call mp_read_keyword(handle, paths(ig), 'observer_y', r_peeloff(ig)%y)
          call mp_read_keyword(handle, paths(ig), 'observer_z', r_peeloff(ig)%z)
       else
          call mp_read_keyword(handle, paths(ig), 'peeloff_x', r_peeloff(ig)%x)
          call mp_read_keyword(handle, paths(ig), 'peeloff_y', r_peeloff(ig)%y)
          call mp_read_keyword(handle, paths(ig), 'peeloff_z', r_peeloff(ig)%z)
       end if

       call mp_read_keyword(handle, paths(ig), 'n_view', n_view)
       call mp_table_read_column_auto(handle, trim(paths(ig))//'/angles', 'theta', theta)
       call mp_table_read_column_auto(handle, trim(paths(ig))//'/angles', 'phi', phi)

       call image_setup(handle,paths(ig),peeled_image(ig),n_view,n_sources,n_dust,use_exact_nu,frequencies)

       ! If an inside observer, check that the longitudes are inverted
       if(inside_observer(ig)) then
          if(peeled_image(ig)%compute_image) then
             if(peeled_image(ig)%x_min < peeled_image(ig)%x_max) call error("peeled_images_setup", "longitudes should increase towards the left for inside observers")
          end if
       end if

       do iv=1,n_view
          ip = ip + 1
          group_id(ip) = ig
          view_id(ip) = iv
          viewing_angles(ip) = angle3d_deg(theta(iv), phi(iv))
       end do

       ! Set up raytracing spectra

       if(use_raytracing) then

          call image_raytracing_initialize(peeled_image(ig),n_sources,n_dust)

          do is=1,n_sources
             select case(s(is)%freq_type)
             case(1)
                call image_raytracing_set_spectrum(peeled_image(ig),is,s(is)%spectrum)
             case(2)
                call image_raytracing_set_blackbody(peeled_image(ig),is,s(is)%temperature)
             case default
                print *,"Don't need to set up spectrum for source = ",is
             end select
          end do

          do id=1,n_dust
             call image_raytracing_set_opacity(peeled_image(ig),id,d(id)%nu,d(id)%chi_nu)
             call image_raytracing_set_emissivity(peeled_image(ig),id,d(id)%j_nu_var,d(id)%j_nu)
          end do

       end if

    end do

    allocate(column_density(n_dust))

  end subroutine peeled_images_setup

  subroutine peeled_images_write(group)

    integer(hid_t),intent(in) :: group
    integer(hid_t) :: g_indiv

    integer :: ig

    character(len=100) :: group_name

    do ig=1,n_groups
       write(group_name, '("group_",I5.5)') ig
       g_indiv = mp_create_group(group, group_name)
       call image_write(peeled_image(ig),g_indiv)
       call mp_write_keyword(g_indiv, '.', 'inside_observer', inside_observer(ig))
       call mp_close_group(g_indiv)
    end do

  end subroutine peeled_images_write

  type(angle3d_dp) function a_peeloff(r, ip)
    implicit none
    type(vector3d_dp), intent(in) :: r
    integer, intent(in) :: ip
    integer :: ig
    ig = group_id(ip)
    if(inside_observer(ig)) then
       call vector3d_to_angle3d(r_peeloff(ig)-r, a_peeloff)
    else
       a_peeloff = viewing_angles(ip)
    end if
  end function a_peeloff

end module peeled_images


* $Id$
      subroutine destdul(ikbl,nbls,nblok1,ncs,inx,buf,
     *     buffer, icfx,jcfx,kcfx,lcfx, q4, use_q4,
     *     icfg,jcfg,kcfg,lcfg,ngcd,lnijkl,indxp,ipres,iqorder,
     *     map_txs_pnl)
c----------------------------------------------------------------
c     gradient derivatives
c
c     This is called for PNL-requested set of contracted shell quartets.
c     Only non-zero Integrals return WITH labels and they do not have
c     to be in PNL-requested order.
c
c     buf           - in-comming integrals
c
c     buffer        - outgoing integrals
c     icfx()-lcfx() - corresponding labels (PNL)
c----------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      integer map_txs_pnl(*)    ! txs to pnl basis map = ncfunct
      logical use_q4
      common /contr/ ngci,ngcj,ngck,ngcl,lci,lcj,lck,lcl,lcij,lckl
      common /lengt/ ilen,jlen,klen,llen, ilen1,jlen1,klen1,llen1
      common /neglect/ eps,eps1,epsr
      common /pnl002/ ncshell,ncfunct,nblock2,integ_n0
      common /intgop/ ncache,maxprice,iprint,iblock
c----------------------------------------------------------------------
      double precision savezerotol
      common /csavezerotol/ savezerotol ! Used in detbul,set in texas_hf
c----------------------------------------------------------------------
c
      dimension icfx(*),jcfx(*),kcfx(*),lcfx(*)
      dimension nblok1(2,*)
      dimension buf(9,nbls,lnijkl,ngcd)
      dimension inx(12,*)
c
cccc  dimension buffer(9,*)
      dimension buffer(12,*)
c
      dimension icfg(*),jcfg(*),kcfg(*),lcfg(*)
      dimension ipres(*), iqorder(*)
      dimension indxp(*)
      dimension q4(*)
      dimension lder(12)        ! to re-order derivativs according to atoms
      dimension iix(4)
c
      double precision xtmp(12)
c
      double precision threshold ! For screening output integrals
c--------------------------------
c     do not zero out integ_n0 here
c----------------------------
c     loop over quartets belonging to the block IKBL :
c
c
      do 10  ijklp=1,nbls
         ijkl=indxp(ijklp)
         if(ijkl.eq.0) go to 10
         iqreq=ipres(ijkl)
         if(iqreq.eq.0) go to 10
         iorder=iqorder(iqreq)
c     test
c     write(6,*)'destDul iorder=',iorder
c     test
         call reorder_der1(iorder,lder)
         if(use_q4) THEN
            symfact=q4(iqreq)
         else
            symfact = 1.0d0
         endif
c
         threshold = savezerotol/symfact
c
c---------------------------------------
c     write(6 ,1230)  ijkl,iqreq,iorder
c     1230 format('quart=',i5,' req-quart=,i5,'  iorder=',i4 )
c---------------------------------------
         ijcs=nblok1(1,ijkl)
         klcs=nblok1(2,ijkl)
         call get_ij_half(ijcs,ics,jcs)
         call get_ij_half(klcs,kcs,lcs)
         if(ngcd.eq.1) then
            ngcq=1
            icfg(1)=inx(11,ics)
            jcfg(1)=inx(11,jcs)
            kcfg(1)=inx(11,kcs)
            lcfg(1)=inx(11,lcs)
         else
            call indexg(inx,ics,jcs,kcs,lcs,ijcs,klcs,
     *           ilen,jlen,klen,llen, icfg,jcfg,kcfg,lcfg,ngcq)
         endif
c
         do iqu=1,ngcq
            icff=icfg(iqu)
            jcff=jcfg(iqu)
            kcff=kcfg(iqu)
            lcff=lcfg(iqu)
            icff=map_txs_pnl(icff+1)-1 ! Relies on txs order = pnl order
            jcff=map_txs_pnl(jcff+1)-1
            kcff=map_txs_pnl(kcff+1)-1
            lcff=map_txs_pnl(lcff+1)-1
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
            integ=0
            do icf=icff+1,icff+ilen
               do jcf=jcff+1,jcff+jlen
                  do kcf=kcff+1,kcff+klen
                     do lcf=lcff+1,lcff+llen
                        integ=integ+1
c------>                   xint0=buf(integ)
                        xtmp( 1)=buf(1,ijklp,integ,iqu) ! xinta
                        xtmp( 2)=buf(4,ijklp,integ,iqu) ! yinta
                        xtmp( 3)=buf(7,ijklp,integ,iqu) ! zinta
                        xtmp( 4)=buf(2,ijklp,integ,iqu) ! xintb
                        xtmp( 5)=buf(5,ijklp,integ,iqu) ! yintb
                        xtmp( 6)=buf(8,ijklp,integ,iqu) ! zintb
                        xtmp( 7)=buf(3,ijklp,integ,iqu) ! xintc
                        xtmp( 8)=buf(6,ijklp,integ,iqu) ! yintc
                        xtmp( 9)=buf(9,ijklp,integ,iqu) ! zintc
                        xnorm = 0.0d0
                        do i = 1, 9
                           xnorm = xnorm + xtmp(i)*xtmp(i)
                        enddo
                        if (xnorm .gt. threshold*threshold) then
                           xtmp(10)=-(xtmp(1)+xtmp(4)+xtmp(7))
                           xtmp(11)=-(xtmp(2)+xtmp(5)+xtmp(8))
                           xtmp(12)=-(xtmp(3)+xtmp(6)+xtmp(9))
                           integ_n0=integ_n0+1
                           do i = 1, 12
                              buffer(lder(i),integ_n0) = xtmp(i)*symfact
                           enddo
                           call lab_req(iorder,icf,jcf,kcf,lcf,iix)
c
c---------------------------> icfx(integ_n0)=icf
c     jcfx(integ_n0)=jcf
c     kcfx(integ_n0)=kcf
c---------------------------> lcfx(integ_n0)=lcf
                           icfx(integ_n0)=iix(1)
                           jcfx(integ_n0)=iix(2)
                           kcfx(integ_n0)=iix(3)
                           lcfx(integ_n0)=iix(4)
c
                           if(iprint.ge.2) then
                              call print_der1(ics,jcs,kcs,lcs,inx,
     *                             buf(1,ijklp,integ,iqu),
     *                             icf,jcf,kcf,lcf)
                           endif
                        endif   !   threshold
                     enddo
                  enddo
               enddo
            enddo
         enddo
c
 10   continue
c--------------------------------------------------------
      end


        SUBROUTINE ZCLPAT(READNO,ET,EPSET,XOFF,EXPO,PERCNT,TOTOBS,
     *                                  ISTAT)
*
*  Module number:
*
*  Module name: zclpat
*
*  Keyphrase:
*  ----------
*       Compute pattern information
*
*  Description:
*  ------------
*       This routine computes the exposure times for each substep
*       bin and the combaddition pattern.
*
*  FORTRAN name: zclpat
*
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       zgetbt
*  SDAS:
*       ZMSPUT
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Feb 89  D. Lindler      Designed and coded
*      1.1      Nov 96  M. De La Pena   Added STPTIM to HRSDEF
*-------------------------------------------------------------------------------
*
* INPUT PARAMETERS
*       readno - readout number
*       et - engineering trailer REAL 24X7
*       epset - data quality for et REAL 24 X 7
*
* Output parameters
*       xoff - combaddition offsets (in diodes) integer
*       expo - exposure time (seconds) for each bin (real)
*       percnt - 5 x 7 array giving percent of the total exposure time
*               spent on each initial deflection running from 1-5 and
*               each substep bin running from 1-7
*	totobs - total observation time
*
        INTEGER READNO,XOFF(7)
        REAL ET(24,7),EPSET(24,7),EXPO(7),PERCNT(5,7),TOTOBS
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C                       /HRSDEF/
C Deflection pattern common block
C       NBINS - Number of supstep bins
C       NINIT - number of initial deflection pairs
C       IXDEF(5) - initial x-deflections
C       XDEF(7) - x-deflections for each bin
C       YDEF(7) - y-deflections for each bin
C       RCODES(7) - repeat codes for each bin
C       BINIDS(7) - substep bins ids for each bin
C       SAMPLE(7) - starting sample position for each spectra
C       LINE(7) - starting line position for each spectra
C       DELTAS(7) - sample position increment for each spectra
C       HOFF(7),VOFF(7) - horizontal and vertical offsets
C       DOPMAG, DOPZER - dopler magnitude and zero time
C       XDCAL, XDCALP - x-deflection calibration parameters
C       STPTIM - integration time at each step pattern position
C
        INTEGER NBINS,NINIT,IXDEF(5),XDEF(7),YDEF(7),RCODES(7)
        INTEGER BINIDS(7),HOFF(7),VOFF(7)
        REAL SAMPLE(7),LINE(7),DELTAS(7),DOPMAG,XDCAL,XDCALP
        DOUBLE PRECISION DOPZER,STPTIM
        COMMON /HRSDEF/ DOPZER,STPTIM,NBINS,NINIT,IXDEF,XDEF,YDEF,
     *                  RCODES,BINIDS,SAMPLE,LINE,DELTAS,HOFF,VOFF,
     *                  DOPMAG,XDCAL,XDCALP
C
C LOCAL VARIABLES
C
        CHARACTER*80 CONTXT
        INTEGER INT,INTEG,I,J,ISTAT
        INTEGER NC1,MAXRC,NTIMES,NLAST,NLEFT
        INTEGER NCOADD(7)
        REAL E
C
C------------------------------------------------------------------------------
C
C COMPUTE THE MAXIMUM REPEAT CODE
C
        MAXRC = 0
        DO 6 I=1,NBINS
6               IF(RCODES(I) .GT. MAXRC) MAXRC=RCODES(I)
C
C LOOP ON BINS ------------------------------------------
C
        TOTOBS = 0.0
        DO 100 I=1,NBINS
C
C compute exposure time for the bin
C
            IF((EPSET(21,I).GT.0.0).OR.(EPSET(23,I).GT.0.0))THEN
                WRITE(CONTXT,9)I,READNO
9               FORMAT('ERROR: unable to compute exposure time for',
     *                  ' bin:',I2,'  readout:',I6)
                CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
C
C trailer contains fill data (no way to compute exposure)
C
                EXPO(I)=0.0
                NCOADD(I)=1
C
C we can compute an exposure time
C
             ELSE
                INT=ET(21,I)
                CALL ZGETBT(INT,8,15,INTEG)
C                                    --->INTEGRATION TIME
                NCOADD(I)=ET(23,I)
                IF(NCOADD(I).LT.1)NCOADD(I)=1
C                                    --->DDLINK HAS ZERO RECORDED
                E=(0.05*INTEG - 0.002)*NCOADD(I)
                EXPO(I)=E
                TOTOBS = TOTOBS + 0.05*INTEG*NCOADD(I)
            ENDIF
C
C NC1 = The number of coadds per initial deflection pair for each complete
C       pattern
C NTIMES = the number of complete patterns over all initial pairs performed
C NLEFT = the number of coadds in the incomplete pattern
C
            NC1 = MAXRC/RCODES(I)
            NTIMES = NCOADD(I)/NC1/NINIT
            NLEFT = NCOADD(I) - NTIMES*NC1*NINIT
C
C Place number of coadds from complete patterns into output PERCNT array
C
            DO 10 J=1,NINIT
10              PERCNT(J,I) = NTIMES*NC1
C
C Compute the number of address pairs in the last pattern that were
C completed (NLAST) and the number of coadds still not accounted for (NLEFT)
C
            NLAST = NLEFT/NC1
            NLEFT = NLEFT - NLAST*NC1
C
C add coadds for deflection pairs completed in last pattern (if any)
C
            IF (NLAST.GT.0) THEN
                DO 20 J=1,NLAST
20                      PERCNT(J,I) = PERCNT(J,I)+NC1
            ENDIF
C
C add the remaining coadds to an incompleted deflection pair
C
            IF (NLEFT .GT. 0)
     *                  PERCNT(NLAST+1,I)=PERCNT(NLAST+1,I)+NLEFT
C
C Normalize by total number of coadds
C
            DO 30 J=1,NINIT
30              PERCNT(J,I)=PERCNT(J,I)/NCOADD(I)
100     CONTINUE
C END LOOP ON BINS ------------------------------------------
C
C Compute combaddition offsets in diodes (1 diode = 8 deflection units)
C
        DO 200 I=1,NINIT
200             XOFF(I)=(IXDEF(I)-IXDEF(1))/8.0+0.5
        RETURN
        END


7 11 Doubles is a drinking games drinking game.

 Materials

  A community cup
  A pair of dice

Object
  Roll a 7, 11 or doubles to get your friends fed up.

 Rules

  Determine who starts by each rolling one die.  Player with the highest roll starts.
  The first player rolls both dice.  Determine if you rolled an additive 7 or 11, or a doubles.  For example, rolling a 3 and 4 on each die gives a 7.  Herein lies some of the trickiness of this game.  Adding can become difficult when intoxicated.
  If the roll doesnt yield a 7, 11 or doubles, the dice are passed to the next player.
  If the roll does yield a 7, 11 or doubles, the fun starts.
  Fill up the community cup to a chuggable amount.  The more beer in the cup, the harder.  Usually about 2 shots worth is used.
  The roller of the 7, 11 or doubles chooses a drinker.
  Now, the appointed drinker must drink the cup following specific rules.  As soon as the drinker touches the cup, the roller will try to get another 7,11, doubles before the drinker finishes and put their cup back on the table.  It is important for both parties to be paying attention.  The drinker must not accidentally touch the cup before they are ready to drink as fast as possible.  Also, the roller must not touch the dice until the drinker touches the cup.  Otherwise, roles reverse so that the drinker becomes the roller and visa versa.
  If the roller rolls another 7, 11, doubles before the drinker slams down their cup, the drinker must drink again while the roller is trying to get another 7,11, doubles.  Lucky rolls can lead to messed up friends.  If the same person keeps having to drink, another player can make a save, where they grab the cup and drink it.  However, if the roller rolls a 7,11, doubles before the cup is back down on the table...you guessed it!  The person who saved has to drink again (and maybe again).
  If the drinker beats the roller (i.e. the roller does not get 7,11, doubles before the drinker is done and the cup is back on the table), the dice are passed to the person to the left and that person becomes the roller.  (Some people also play that if the drinker wins, they get to roll next.)


MODULE obs_rot_vel
  USE par_kind
  USE par_oce
  USE in_out_manager
  USE dom_oce
  USE obs_grid
  USE obs_utils
  USE obs_profiles_def
  USE obs_inter_h2d
  USE obs_inter_sup
  USE geo2ocean
  USE obs_fbm
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: obs_rotvel
  CONTAINS
  SUBROUTINE obs_rotvel(profdata, k2dint, pu, pv)
    TYPE(obs_prof), INTENT(INOUT) :: profdata
    INTEGER, INTENT(IN) :: k2dint
    REAL(KIND = wp), DIMENSION(*) :: pu, pv
    REAL(KIND = wp), DIMENSION(2, 2, 1) :: zweig
    REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE :: zmasku, zmaskv, zcoslu, zsinlu, zcoslv, zsinlv, zglamu, zgphiu, zglamv, zgphiv
    REAL(KIND = wp), DIMENSION(1) :: zsinu, zcosu, zsinv, zcosv
    REAL(KIND = wp) :: zsin
    REAL(KIND = wp) :: zcos
    REAL(KIND = wp), DIMENSION(1) :: zobsmask
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zsingu, zcosgu, zsingv, zcosgv
    INTEGER, DIMENSION(:, :, :), ALLOCATABLE :: igrdiu, igrdju, igrdiv, igrdjv
    INTEGER :: ji
    INTEGER :: jk
    ALLOCATE(igrdiu(2, 2, profdata % nprof), igrdju(2, 2, profdata % nprof), zglamu(2, 2, profdata % nprof), zgphiu(2, 2, profdata % nprof), zmasku(2, 2, profdata % nprof), zcoslu(2, 2, profdata % nprof), zsinlu(2, 2, profdata % nprof), igrdiv(2, 2, profdata % nprof), igrdjv(2, 2, profdata % nprof), zglamv(2, 2, profdata % nprof), zgphiv(2, 2, profdata % nprof), zmaskv(2, 2, profdata % nprof), zcoslv(2, 2, profdata % nprof), zsinlv(2, 2, profdata % nprof))
    CALL obs_rot(zsingu, zcosgu, zsingv, zcosgv)
    DO ji = 1, profdata % nprof
      igrdiu(1, 1, ji) = profdata % mi(ji, 1) - 1
      igrdju(1, 1, ji) = profdata % mj(ji, 1) - 1
      igrdiu(1, 2, ji) = profdata % mi(ji, 1) - 1
      igrdju(1, 2, ji) = profdata % mj(ji, 1)
      igrdiu(2, 1, ji) = profdata % mi(ji, 1)
      igrdju(2, 1, ji) = profdata % mj(ji, 1) - 1
      igrdiu(2, 2, ji) = profdata % mi(ji, 1)
      igrdju(2, 2, ji) = profdata % mj(ji, 1)
      igrdiv(1, 1, ji) = profdata % mi(ji, 2) - 1
      igrdjv(1, 1, ji) = profdata % mj(ji, 2) - 1
      igrdiv(1, 2, ji) = profdata % mi(ji, 2) - 1
      igrdjv(1, 2, ji) = profdata % mj(ji, 2)
      igrdiv(2, 1, ji) = profdata % mi(ji, 2)
      igrdjv(2, 1, ji) = profdata % mj(ji, 2) - 1
      igrdiv(2, 2, ji) = profdata % mi(ji, 2)
      igrdjv(2, 2, ji) = profdata % mj(ji, 2)
    END DO
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiu, igrdju, glamu, zglamu)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiu, igrdju, gphiu, zgphiu)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiu, igrdju, umask(:, :, 1), zmasku)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiu, igrdju, zsingu, zsinlu)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiu, igrdju, zcosgu, zcoslu)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiv, igrdjv, glamv, zglamv)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiv, igrdjv, gphiv, zgphiv)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiv, igrdjv, vmask(:, :, 1), zmaskv)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiv, igrdjv, zsingv, zsinlv)
    CALL obs_int_comm_2d(2, 2, profdata % nprof, jpi, jpj, igrdiv, igrdjv, zcosgv, zcoslv)
    DO ji = 1, profdata % nprof
      CALL obs_int_h2d_init(1, 1, k2dint, profdata % rlam(ji), profdata % rphi(ji), zglamu(:, :, ji), zgphiu(:, :, ji), zmasku(:, :, ji), zweig, zobsmask)
      CALL obs_int_h2d(1, 1, zweig, zsinlu(:, :, ji), zsinu)
      CALL obs_int_h2d(1, 1, zweig, zcoslu(:, :, ji), zcosu)
      CALL obs_int_h2d_init(1, 1, k2dint, profdata % rlam(ji), profdata % rphi(ji), zglamv(:, :, ji), zgphiv(:, :, ji), zmaskv(:, :, ji), zweig, zobsmask)
      CALL obs_int_h2d(1, 1, zweig, zsinlv(:, :, ji), zsinv)
      CALL obs_int_h2d(1, 1, zweig, zcoslv(:, :, ji), zcosv)
      zcos = 0.5_wp * (zcosu(1) + zcosv(1))
      zsin = 0.5_wp * (zsinu(1) + zsinv(1))
      IF ((profdata % npvsta(ji, 1) /= profdata % npvsta(ji, 2)) .OR. (profdata % npvend(ji, 1) /= profdata % npvend(ji, 2))) THEN
        CALL fatal_error('Different number of U and V observations ' // 'in a profile in obs_rotvel', 190)
      END IF
      DO jk = profdata % npvsta(ji, 1), profdata % npvend(ji, 1)
        IF ((profdata % var(1) % vmod(jk) /= fbrmdi) .AND. (profdata % var(2) % vmod(jk) /= fbrmdi)) THEN
          pu(jk) = profdata % var(1) % vmod(jk) * zcos - profdata % var(2) % vmod(jk) * zsin
          pv(jk) = profdata % var(2) % vmod(jk) * zcos + profdata % var(1) % vmod(jk) * zsin
        ELSE
          pu(jk) = fbrmdi
          pv(jk) = fbrmdi
        END IF
      END DO
    END DO
    DEALLOCATE(igrdiu, igrdju, zglamu, zgphiu, zmasku, zcoslu, zsinlu, igrdiv, igrdjv, zglamv, zgphiv, zmaskv, zcoslv, zsinlv)
  END SUBROUTINE obs_rotvel
END MODULE obs_rot_vel