text:
See also: Juvenile Justice System & Youth for Recovery

The Yolo County Juvenile Drug Court is a Courtsupervised multiagency program employing the 10 Key Foundational Components for Drug Courts, which includes the Probation Dept., Communicare Health Centers, Yolo County Alcohol Drug and Mental Health Dept., and other community resources.  It is a Court, so the District Attorney and Public Defender/Defense Counsel also are involved. School personnel where the juvenile attends school is also an important player.

The process begins with the arrest and adjudication of the teen and where confinement (juvenile hall, etc.) is a possibility.  The teen is given a choice to participate in the Drug Court program instead.  In some instances, the juvenile is courtordered to the program.

A Probation Officer meets with the juvenile and the parents for an interview to assess suitability for participation.  If deemed appropriate, the juvenile is referred to Youth for Recovery for screening and a subsequent assessment.  The assessment is done solely to gather information to determine levels of services needed and to develop a treatment plan. Juveniles accepted into the program either do the Afterschool program or Day Treatment program.  The Judge is required to make the final determination as to suitability and acceptance to the Drug Court program, but Youth for Recovery will start the juvenile on the their treatment program before any Court hearing is done.

In addition to the Youth for Recovery program requirements, Drug Court participants also have weekly Drug Court appearances. In addition, the juvenile is supervised by a Probation Officer, which includes unannounced home visits for search of the area under the control of the juvenile. A curfew is imposed (10:00 pm or earlier depending on the recommendation of the Probation Officer). Perfect attendance and good behavior at all Court hearings, YFR meetings and school is required.  If poor behavior (including poor academic progress) is reported anywhere, then sanctions may be imposed.  Sanctions can be anything from having to write an essay to an order to spend time in juvenile hall.  Lack of progress can result in termination from Drug Court and the juvenile is returned to Juvenile Court for full enforcement of their sentence.

Due to laws that require the identity and privacy of juveniles to be protected, parents and participants are required to sign a statement authorizing the release of confidential treatment information to the Drug Court, specifically information on attendance and results of drug tests are required and progress reports are desired.  Also required is a signed waiver allowing other participants to be present at the Court Hearings.  Everyone scheduled for a hearing attends together and stays for the entire time which can take up to 2 hours.  The Drug Court is very sensitive to the confidential nature of some information that is discussed in the Court and care is taken to discuss more sensitive issues in a more private way, i.e. sidebars with the Judge that are out of earshot of the general public. Hearings for juvenile Drug Court are on Friday afternoons at 2:00 pm, so if a child is participating, parents will need to arrange to get off work to attend with their child.

Summer  As a participant in the Juvenile Drug Court program, you are required to have summer plans which include working (minimum of 20 hours per week, either paid or volunteer), summer school or other planned activities.  Family vacations, camps, etc. can also be included in the summer plan  though scheduling these types of activities is difficult due to the scheduling demands of the program, the requirement that youth on probation usually have to be at their legal residence or with a legal guardian at night, and the requirement that the student hold down a parttime job. Additionally, any missed group meetings only lengthens the duration of the program as time in each phase is measured in group meetings attended.  At best, the family can try to avoid feeling trapped in Davis by going on short day trips to regional venues  rafting, bike rides, Marine World, state and county fairs, etc. Forget that weeklong annual family camping trip or your child attending Scout/Sport/music camp.  Summer plans are reviewed by the Judge at the beginning of summer.  Juveniles in the Day Treatment program meet 3 hours per day at the John H. Jones clinic in Woodland to continue their program during the summer break.

To graduate, participants must be clean and sober for a minimum of 6 months & complete the 4 phases of their treatment. Graduates of the Juvenile Drug Court program may be rewarded with a reduction of their sentence, including dismissal of charges if deemed appropriate by the Court.  It is noted that the program is not easy to complete.  The graduation rate for the program is only 18% (1 child out of 5 children graduate).  Failure to complete is considered a violation of probation, or, if adjudication has been deferred, failure to complete diversion.  Parents should go into the program with the understanding that chances are they will not complete and eventually may be given more severe probation requirements or a period of confinement by the Court.  Only children who are heavy drug users, beyond parental control and in need intervention and treatment should participate in Juvenile Drug Court.

The program is a minimum of 8 months long.  Families should expect their child to be in the program for sometimes up to a year or two.  All participants are made wards of the Court and parents are generally excluded from drug court team discussions and decisions.

Former Judges for the Yolo County Juvenile Drug Court have been Honorable Doris Shockley, Honorable David Rosenberg (until 7/3/2006), and Honorable Steven Basha (until 12/31/2006) and Commissioner Paul K. Richardson.

Currently, Judge Gaar presides over the courts specialty calendar, including Adult/Juvenile Drug Court and domestic violence cases (3/2008)

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      program type24

C     No substring operator is applied interprocedurally although s1 and
C     s2 should receive different values

      character*20 s1
      character*2 s2

      call foo(s1)
      call foo(s2)

      print *, s1, s2

      end

      subroutine foo(s)

C     Variable and constant lengths must be taken into account and
C     substring applied... except when you cannot and have to assume
C     that the assignment is legal

      character*(*) s

C     Should not be truncated since the actual lenght of s is unknown
      s = "Hello World!"

      end

ext: f


text:
I moved to Davis from the Bay Area in the fall of 08. I work at the Department of Mental Health in Sactown and I love it :).

My interests include:
Sushi buffets and burritos from Guad
Psychology
Classical novels
Gardening (to some extent, although living in an apartment kinda limits your options here)
Punk concerts
Concerts of any kind (music is better when experienced live)

20090507 10:01:18 nbsp Hey, Amy.  I was wondering if you could email me.  I have a fairly simple personal question that you might be able to help me out with.  Mailto(jw.dw AT timewarp DOT org).  Thanks.  Users/JabberWokky Evan JabberWokky Edwards

20090507 11:43:03 nbsp Check your email :) Users/AmyLeigh


text:
      MODULE blandc_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.3E  14:44:54  12/27/06
      SUBROUTINE blandc (VARMAX, CFMAX, LOCK, MED, MINJ, MAXJ, NMAX, POSN, POSL&
         , LIM)
      integer :: VARMAX
      integer, INTENT(IN) :: CFMAX
      logical, DIMENSION(15,0:10), INTENT(IN) :: LOCK
      logical, DIMENSION(15,0:10), INTENT(IN) :: MED
      integer :: MINJ
      integer :: MAXJ
      integer, INTENT(IN) :: NMAX
      integer, DIMENSION(110), INTENT(IN) :: POSN
      integer, DIMENSION(110), INTENT(IN) :: POSL
      integer, DIMENSION(15) :: LIM
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:36:28 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE END_GENIE__genmod
          INTERFACE
            SUBROUTINE END_GENIE
            END SUBROUTINE END_GENIE
          END INTERFACE
        END MODULE END_GENIE__genmod


text:
PROGRAM main
  implicit none

  real   :: xx,yy,zz

  xx=10.
  zz=15.678e0

  call test(xx,yy,zz)

  print*, 'xx= ', xx, ' yy= ', yy, ' zz= ', zz

CONTAINS
  SUBROUTINE test(x,y,z)
    implicit none

    real, intent(in)    :: x
    real, intent(out)   :: y
    real, intent(inout) :: z

!    x=10  ! Compilation error
!    z=y+1 ! Dangerous as the compiler assumes y is out only
    z=19  ! correct
    y=z*x ! correct

  END SUBROUTINE test
END PrOGRAM main

max_stars_repo_name: annefou/Fortran


text:
Describe Users/jonwoo here.

20130410 18:03:29 nbsp Welcome to the Wiki, Jon.  I have read your comment and all I can say is...wow. That is all VERY disturbing...very cultish. Very scary. It appears you have had some time to heal and recover. Hope others can gain some wisdom from your testimony. Users/PeteB

20130506 15:09:10 nbsp Jonyou posted the same info on Waypoint as on Gracepoint Davis Church. You are aware that they arent relatedright??? Doesnt seem to fair to cast aspersions on another group unrelated to the organization you actually did have issues with. Please join in the discussion on Waypoint/TalkUsers/PeteB

20130912 12:18:13 nbsp Jon please be aware that if you click on the info tab, you can see the name or info about anyone posting a comment. With the material youre posting being so inflammatory you should properly attribute your comments. I have reattributed your comments to your name. Users/PeteB

20130913 10:26:22 nbsp That is fine, it was probably deleted by accident when I edited it Users/jonwoo

20130913 16:25:42 nbsp Jon: Sorry man but I find this difficult to believe thisreason being because you removed your name from Gracepoint Davis Church as well and thats the only edit you made. If youre wondering I have no affiliation with Gracepoint or Koinonia in any manner. Users/PeteB

20130918 11:43:47 nbsp I figured it was unwise to leave an email address up, so i meant to delete that. I guess I deleted the name too when i did that Users/jonwoo


text:
!##############################################################################
!     ________  _____  ______________
!    / ____/  |/  / / / /_  __/  _/ /
!   / /_  / /|_/ / / / / / /  / // /
!  / __/ / /  / / /_/ / / / _/ // /___
! /_/   /_/  /_/\____/ /_/ /___/_____/
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       Search Module
!! \details     This module provides functions for search utilities
!! \author      Bharat Mahajan
!! \date        Created: 07/31/2019
!
!##############################################################################

!> Module containing all the utility functions
module Search

    use FMUTILBase

    implicit none

    !> Max iterations for the root-finding
    integer, parameter :: MAX_ITERATIONS = 50

    !> Interface of the function whose root needs to be computed
    abstract interface
        pure function func(x) result(y)
            import :: WP
            implicit none
            real(WP), intent(in) :: x !< independent variable
            real(WP) :: y
        end function func
    end interface

    contains

    !> \brief Performs binary search on a provided sorted array
    !! \details TBD
    pure function BinarySearch(SortedX, SortedDataArray)

        !import :: WP

        implicit none

        real(WP), dimension(1:), intent(in)  :: SortedX    !< Element to find
        real(WP), dimension(:), intent(in)  :: SortedDataArray   !< Ascending-order sorted vector
        integer, dimension(size(SortedX)) :: BinarySearch

        integer :: lb, ub, a, b, m, n, ctr, xloc
        real(WP) :: x

        ! initialize
        lb = 1
        ub = size(SortedDataArray)
        m = lb

        ! for each element
        do ctr = 1, size(SortedX)

            ! element to search for
            x = SortedX(ctr)

            ! current interval. Note we assume that the array of the elements
            ! to search for is also a sorted array.
            a = m
            b = ub

            ! loop for finding the element
            do
                ! size of the current interval
                n = b - a + 1

                ! mid-point
                m = floor((n+1)/2.0) + (a-1)

                if (x < SortedDataArray(m)) then
                    ! search the lower half
                    b = m
                    cycle
                elseif (x > SortedDataArray(m) .AND. (m+1) /= b) then
                    ! search the upper half
                    a = m
                    cycle
                else
                    ! We either have found the exact match
                    ! Or x lies in between Data(m) and Data(m+1)
                    xloc = m
                    exit
                end if
            end do

            ! save the location of the current element
            BinarySearch(ctr) = xloc
        end do

    end function BinarySearch

end module Search

max_stars_repo_name: princemahajan/FMUTIL

max_issues_repo_name: princemahajan/FMUTIL

max_forks_repo_name: princemahajan/FMUTIL


text:
Address(Antelope Avenue) is a residential street in North Davis.

 Intersecting Streets

  Sycamore Lane where it turns into County Road 100A
  Quail Street
  Sparrow Court
  Antelope Road


text:
program read_snapshot

   !------------------------------------------------------------------
   ! This Fortran 90 routine shows how a snapshot of GADGET
   ! which is distributed into several files may be read in.
   ! In this example, coodinates of particles type 1 are read.
   !
   ! Each dump consists of several files, each with a variable
   ! number of particles. However, these files all have the same format.
   ! The sequence of information in the files is as follows:
   !
   ! Header
   ! Positions
   ! Velocities
   ! Particle ID's
   !
   ! Masses (for particle types with vanishing mass entry in the header)
   ! Internal Energy (Gas)
   ! Density (Gas)
   !
   !-------------------------------------------------------------------

   include 'globals.h'
   integer :: NFILES

   character*200 fileroot,filename, fnumber

   integer*4 npfile(1:6), nall(1:6)
   real*8    massarr(1:6)
   real*8    a
   real*8    z
   integer*4 unused(34)
   integer*4 fn,i,nstart,flag_sfr,flag_feedback
   integer*4 N,Ntot,Nwithmass,Ntotwithmass,nmass

   real*4,allocatable    :: rpos(:,:),rvel(:,:),rmass(:)
   integer*4,allocatable :: id(:)
   real :: mscale,vscale,tscale,lscale
   call initmem(nbodsmax,nsphmax,ncells)

   unitm_in_msun=1.e9
   unitl_in_kpc=1.
   timescale=1.488e19*unitl_in_kpc*sqrt(unitl_in_kpc/unitm_in_msun)
   lengthscale=3.086e21*unitl_in_kpc
   velscale=lengthscale/timescale

   print*,'single gadget file conversion'
   print*,'fileroot?'
   read*,fileroot
   print*,'mscale (in msun)?'
   read*,mscale
   mscale=mscale/unitm_in_msun
   print*,'vscale (in km/s)?'
   read*,vscale
   vscale=1.e5*vscale/velscale
   print*,'tscale (in Myr)?'
   read*,tscale
   tscale=tscale/timescale*year*1.e6
   print*,'m,v,t factor:',mscale,vscale,tscale
   lscale=1

   filename=trim(fileroot)

   print *,'opening...  '//trim(filename)

   ! now, read in the header

   open (1, file=filename, form='unformatted')
   read (1) npfile, massarr ,a, z, flag_sfr,flag_feedback, nall, unused

   do i=1,6
      print *,'Type,npfile,massarr',i, nall(i), massarr(i)
   end do

   Ntot= sum(nall)
   N=sum(npfile)

   Nwithmass=0
   do i=1,6
    if(massarr(i).EQ.0) Nwithmass=Nwithmass+npfile(i)
   enddo

   allocate(rpos(1:3,1:N),rvel(1:3,1:N),id(1:N))
   if(Nwithmass.gt.0) allocate(rmass(1:Nwithmass))

   read (1) rpos
   read (1) rvel
   read (1) id
   if(Nwithmass.gt.0) read (1) rmass
   close (1)

   print *,'Done with reading.'

   nbodies=Ntot
   nsph=npfile(1)
   nstar=sum(npfile(3:6))
   nbh=npfile(6)
   totptag=nbodies
   tnow=a*tscale
   massres=0.

   if(nbodies.GT.nbodsmax.OR.nsph.GT.nsphmax) then
    print*,"particle overflow:",nbodies,nsph
    stop
   endif

   outputfile=fileroot
   firstsnap=0
   uentropy=.FALSE.
   output=0
   output(1:3)=1

   do i=1,nbodies
   pos(i,1:3)=rpos(1:3,i)*lscale
   vel(i,1:3)=rvel(1:3,i)*vscale
   enddo
   nmass=1
   nstart=1
   do i=1,6
    if(massarr(i).eq.0) then
      mass(nstart:nstart+npfile(i)-1)=rmass(nmass:nmass+npfile(i)-1)
      nstart=nstart+npfile(i)
      nmass=nmass+npfile(i)
    else
      mass(nstart:nstart+npfile(i)-1)=massarr(i)
      nstart=nstart+npfile(i)
    endif
   enddo
   mass=mass*mscale

   if(Nwithmass.gt.0) deallocate(rmass)
   deallocate(rpos,rvel,id)

   print*,'fill ethermal (T= 10^4 K)'
   output(11)=0
   if(nsph.gt.0) then
    output(11)=1
    ethermal(1:nsph) =1.e4/4.86e5 ! 10^4 K
   endif

   print*,'fill tform (age=12.e9 yr)'
   output(5)=1
   tform(1:nbodies)=0.
   allocate(rmass(nstar))
   call random_number(rmass)
   tform(nbodies-nstar+1:nbodies)=-rmass*800
deallocate(rmass)

   call outbods(trim(fileroot)//".new")
end program

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
!==============================================================================!
  subroutine Turb_Mod_Src_F22_Rsm_Manceau_Hanjalic(turb, sol)
!------------------------------------------------------------------------------!
!   Calculate source terms in eliptic relaxation equation                      !
!   and imposing  boundary condition forf22                                    !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type),   target :: turb
  type(Solver_Type), target :: sol
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type),  pointer :: flow
  type(Grid_Type),   pointer :: grid
  type(Var_Type),    pointer :: f22
  type(Matrix_Type), pointer :: a
  real,              pointer :: b(:)
  integer                    :: s, c, c1, c2
  real                       :: sor11,  f22hg
!==============================================================================!
!                                                                              !
!   The form of source terms are :                                             !
!                                                                              !
!     /                                                                        !
!    |                                                                         !
!    | f22hg*dV ; f22hg - f22hg homogenious is placed in a source              !
!    |                     coefficients b(c)                                   !
!   /                                                                          !
!      f22hg = (1.0 - Cv_1)*(vi2(c)/kin(c) - 2.0/3.0)/Tsc(c)     &             !
!              + 2.0*Cv_2*p_kin(c)/(3.0*kin(c))                                !
!                                                                              !
!     /                                                                        !
!    |                                                                         !
!    | f22*dV ;this term is placed in a diagonal of coefficient matrice        !
!    |                                                                         !
!   /                                                                          !
!                                                                              !
!                                                                              !
!  Dimensions of certain variables                                             !
!                                                                              !
!     Tsc            [s]                                                       !
!     kin            [m^2/s^2]                                                 !
!     eps            [m^3/s^2]                                                 !
!     vi2            [m^2/s^2]                                                 !
!     f22            [-]                                                       !
!     l_scale        [m]                                                       !
!                                                                              !
!------------------------------------------------------------------------------!

  ! Take aliases
  flow => turb % pnt_flow
  grid => flow % pnt_grid
  f22  => turb % f22
  call Solver_Mod_Alias_System(sol, a, b)

  call Time_And_Length_Scale(grid, turb)

  ! Source term f22hg
  do c = 1, grid % n_cells
    f22hg = 1.0
    sor11 = grid % vol(c) / turb % l_scale(c)**2
    a % val(a % dia(c)) = a % val(a % dia(c)) + sor11
    b(c) = b(c) + f22hg * grid % vol(c) / turb % l_scale(c)**2
  end do

  ! Source term
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c2 < 0) then
      if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL .or.  &
         Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) then

          f22 % n(c2) = 0.0

      end if   ! end if of BC=wall
    end if    ! end if of c2<0
  end do

  end subroutine

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


MODULE domwri
  USE dom_oce
  USE phycst, ONLY: rsmall
  USE wet_dry, ONLY: ll_wd
  USE in_out_manager
  USE iom
  USE lbclnk
  USE lib_mpp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: dom_wri
  PUBLIC :: dom_stiff
  CONTAINS
  SUBROUTINE dom_wri
    INTEGER :: inum
    CHARACTER(LEN = 21) :: clnam
    INTEGER :: ji, jj, jk
    INTEGER :: izco, izps, isco, icav
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zprt, zprw
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdepu, zdepv
    IF (lwp) WRITE(numout, FMT = *)
    IF (lwp) WRITE(numout, FMT = *) 'dom_wri : create NetCDF mesh and mask information file(s)'
    IF (lwp) WRITE(numout, FMT = *) '~~~~~~~'
    clnam = 'mesh_mask'
    CALL iom_open(TRIM(clnam), inum, ldwrt = .TRUE., kiolib = jprstlib)
    CALL iom_rstput(0, 0, inum, 'jpiglo', REAL(jpiglo, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jpjglo', REAL(jpjglo, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jpkglo', REAL(jpkglo, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'jperio', REAL(jperio, wp), ktype = jp_i4)
    IF (ln_zco) THEN
      izco = 1
    ELSE
      izco = 0
    END IF
    IF (ln_zps) THEN
      izps = 1
    ELSE
      izps = 0
    END IF
    IF (ln_sco) THEN
      isco = 1
    ELSE
      isco = 0
    END IF
    CALL iom_rstput(0, 0, inum, 'ln_zco', REAL(izco, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'ln_zps', REAL(izps, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'ln_sco', REAL(isco, wp), ktype = jp_i4)
    IF (ln_isfcav) THEN
      icav = 1
    ELSE
      icav = 0
    END IF
    CALL iom_rstput(0, 0, inum, 'ln_isfcav', REAL(icav, wp), ktype = jp_i4)
    CALL iom_rstput(0, 0, inum, 'tmask', tmask, ktype = jp_i1)
    CALL iom_rstput(0, 0, inum, 'umask', umask, ktype = jp_i1)
    CALL iom_rstput(0, 0, inum, 'vmask', vmask, ktype = jp_i1)
    CALL iom_rstput(0, 0, inum, 'fmask', fmask, ktype = jp_i1)
    CALL dom_uniq(zprw, 'T')
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        zprt(ji, jj) = ssmask(ji, jj) * zprw(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1)
    CALL dom_uniq(zprw, 'U')
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        zprt(ji, jj) = ssumask(ji, jj) * zprw(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'umaskutil', zprt, ktype = jp_i1)
    CALL dom_uniq(zprw, 'V')
    !$ACC KERNELS
    DO jj = 1, jpj
      DO ji = 1, jpi
        zprt(ji, jj) = ssvmask(ji, jj) * zprw(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'vmaskutil', zprt, ktype = jp_i1)
    CALL iom_rstput(0, 0, inum, 'glamt', glamt, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamu', glamu, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamv', glamv, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'glamf', glamf, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphit', gphit, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphiu', gphiu, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphiv', gphiv, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gphif', gphif, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1t', e1t, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1u', e1u, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1v', e1v, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e1f', e1f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2t', e2t, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2u', e2u, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2v', e2v, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e2f', e2f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'ff_f', ff_f, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'ff_t', ff_t, ktype = jp_r8)
    !$ACC KERNELS
    zprt(:, :) = ssmask(:, :) * REAL(mbkt(:, :), wp)
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'mbathy', zprt, ktype = jp_i4)
    !$ACC KERNELS
    zprt(:, :) = ssmask(:, :) * REAL(mikt(:, :), wp)
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'misf', zprt, ktype = jp_i4)
    !$ACC KERNELS
    zprt(:, :) = ssmask(:, :) * REAL(risfdep(:, :), wp)
    !$ACC END KERNELS
    CALL iom_rstput(0, 0, inum, 'isfdraft', zprt, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3t_0', e3t_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3u_0', e3u_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3v_0', e3v_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'e3w_0', e3w_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gdept_1d', gdept_1d, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gdepw_1d', gdepw_1d, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gdept_0', gdept_0, ktype = jp_r8)
    CALL iom_rstput(0, 0, inum, 'gdepw_0', gdepw_0, ktype = jp_r8)
    IF (ln_sco) THEN
      CALL dom_stiff(zprt)
      CALL iom_rstput(0, 0, inum, 'stiffness', zprt)
    END IF
    IF (ll_wd) CALL iom_rstput(0, 0, inum, 'ht_0', ht_0, ktype = jp_r8)
    CALL iom_close(inum)
  END SUBROUTINE dom_wri
  SUBROUTINE dom_uniq(puniq, cdgrd)
    CHARACTER(LEN = 1), INTENT(IN   ) :: cdgrd
    REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: puniq
    REAL(KIND = wp) :: zshift
    INTEGER :: ji
    LOGICAL, DIMENSION(SIZE(puniq, 1), SIZE(puniq, 2), 1) :: lldbl
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: ztstref
    !$ACC KERNELS
    zshift = jpi * jpj * (narea - 1)
    ztstref(:, :) = RESHAPE((/(zshift + REAL(ji, wp), ji = 1, jpi * jpj)/), (/jpi, jpj/))
    puniq(:, :) = ztstref(:, :)
    !$ACC END KERNELS
    CALL lbc_lnk(puniq, cdgrd, 1.)
    !$ACC KERNELS
    lldbl(:, :, 1) = puniq(:, :) == ztstref(:, :)
    puniq(:, :) = 1.
    puniq(nldi : nlei, nldj : nlej) = REAL(COUNT(lldbl(nldi : nlei, nldj : nlej, :), dim = 3), wp)
    !$ACC END KERNELS
  END SUBROUTINE dom_uniq
  SUBROUTINE dom_stiff(px1)
    REAL(KIND = wp), DIMENSION(:, :), INTENT(OUT), OPTIONAL :: px1
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zrxmax
    REAL(KIND = wp), DIMENSION(4) :: zr1
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zx1
    !$ACC KERNELS
    zx1(:, :) = 0._wp
    zrxmax = 0._wp
    !$ACC END KERNELS
    zr1(:) = 0._wp
    DO ji = 2, jpim1
      DO jj = 2, jpjm1
        DO jk = 1, jpkm1
          zr1(1) = ABS((gdepw_0(ji, jj, jk) - gdepw_0(ji - 1, jj, jk) + gdepw_0(ji, jj, jk + 1) - gdepw_0(ji - 1, jj, jk + 1)) / (gdepw_0(ji, jj, jk) + gdepw_0(ji - 1, jj, jk) - gdepw_0(ji, jj, jk + 1) - gdepw_0(ji - 1, jj, jk + 1) + rsmall)) * umask(ji - 1, jj, jk)
          zr1(2) = ABS((gdepw_0(ji + 1, jj, jk) - gdepw_0(ji, jj, jk) + gdepw_0(ji + 1, jj, jk + 1) - gdepw_0(ji, jj, jk + 1)) / (gdepw_0(ji + 1, jj, jk) + gdepw_0(ji, jj, jk) - gdepw_0(ji + 1, jj, jk + 1) - gdepw_0(ji, jj, jk + 1) + rsmall)) * umask(ji, jj, jk)
          zr1(3) = ABS((gdepw_0(ji, jj + 1, jk) - gdepw_0(ji, jj, jk) + gdepw_0(ji, jj + 1, jk + 1) - gdepw_0(ji, jj, jk + 1)) / (gdepw_0(ji, jj + 1, jk) + gdepw_0(ji, jj, jk) - gdepw_0(ji, jj + 1, jk + 1) - gdepw_0(ji, jj, jk + 1) + rsmall)) * vmask(ji, jj, jk)
          zr1(4) = ABS((gdepw_0(ji, jj, jk) - gdepw_0(ji, jj - 1, jk) + gdepw_0(ji, jj, jk + 1) - gdepw_0(ji, jj - 1, jk + 1)) / (gdepw_0(ji, jj, jk) + gdepw_0(ji, jj - 1, jk) - gdepw_0(ji, jj, jk + 1) - gdepw_0(ji, jj - 1, jk + 1) + rsmall)) * vmask(ji, jj - 1, jk)
          zrxmax = MAXVAL(zr1(1 : 4))
          zx1(ji, jj) = MAX(zx1(ji, jj), zrxmax)
        END DO
      END DO
    END DO
    CALL lbc_lnk(zx1, 'T', 1.)
    IF (PRESENT(px1)) px1 = zx1
    zrxmax = MAXVAL(zx1)
    IF (lk_mpp) CALL mpp_max(zrxmax)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'dom_stiff : maximum grid stiffness ratio: ', zrxmax
      WRITE(numout, FMT = *) '~~~~~~~~~'
    END IF
  END SUBROUTINE dom_stiff
END MODULE domwri


text:
module saxpy_mod
  contains
  subroutine saxpy(n, a, x, y)
    integer :: n
    real    :: a, x(:), y(:)
    !$acc parallel loop deviceptr(x,y)
    y(:) = y(:) + a * x(:)
    !$acc end parallel
  end subroutine
end module

max_stars_repo_name: georgebisbas/openacc-interoperability

max_issues_repo_name: georgebisbas/openacc-interoperability

max_forks_repo_name: georgebisbas/openacc-interoperability


! { dg-do run }
! { dg-options "-fdec-structure" }
!
! Test nested UNIONs.
!

subroutine aborts (s)
  character(*), intent(in) :: s
  print *, s
  call abort()
end subroutine

! Nested unions
structure /s4/
  union ! U0                ! rax
    map
      character(16) rx
    end map
    map
      character(8) rh         ! rah
      union ! U1
        map
          character(8) rl     ! ral
        end map
        map
          character(8) ex     ! eax
        end map
        map
          character(4) eh     ! eah
          union ! U2
            map
              character(4) el ! eal
            end map
            map
              character(4) x  ! ax
            end map
            map
              character(2) h  ! ah
              character(2) l  ! al
            end map
          end union
        end map
      end union
    end map
  end union
end structure
record /s4/ r4

! Nested unions
r4.rx     =     'AAAAAAAA.BBB.C.D'

if ( r4.rx .ne. 'AAAAAAAA.BBB.C.D' ) call aborts ("rax")
if ( r4.rh .ne. 'AAAAAAAA'         ) call aborts ("rah")
if ( r4.rl .ne.         '.BBB.C.D' ) call aborts ("ral")
if ( r4.ex .ne.         '.BBB.C.D' ) call aborts ("eax")
if ( r4.eh .ne.         '.BBB'     ) call aborts ("eah")
if ( r4.el .ne.             '.C.D' ) call aborts ("eal")
if ( r4.x  .ne.             '.C.D' ) call aborts ("ax")
if ( r4.h  .ne.             '.C'   ) call aborts ("ah")
if ( r4.l  .ne.               '.D' ) call aborts ("al")

end


text:
      MODULE gethes_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  12:12:16  03/10/06
      SUBROUTINE gethes (XPARAM, IGTHES, NVAR, ILOOP, HESS, PMAT, BMAT)
      USE vast_kind_param,ONLY: DOUBLE
      real(DOUBLE), DIMENSION(*), INTENT(OUT) :: XPARAM
      integer, INTENT(IN) :: IGTHES
      integer, INTENT(IN) :: NVAR
      integer, INTENT(IN) :: ILOOP
      real(DOUBLE), DIMENSION(NVAR,NVAR), INTENT(INOUT) :: HESS
      real(DOUBLE), DIMENSION(NVAR*NVAR) :: PMAT
      real(DOUBLE), DIMENSION(NVAR,NVAR) :: BMAT
      END SUBROUTINE
      END INTERFACE
      END MODULE

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive