      subroutine hcsout_output

      use hydrograph_module
      use time_module
      use constituent_mass_module

      implicit none

      integer :: iiout            !none          |counter
      integer :: ipest            !none          |pesticide counter
      integer :: ipath            !none          |pathogen counter
      integer :: imetal           !none          |heavy metal counter
      integer :: isalt            !none          |salt counter
      integer :: iob              !none          |object counter

      do iob = 1, sp_ob%objs
        do iiout = 1, ob(iob)%src_tot
        !! daily print
         if (pco%day_print == "y" .and. pco%int_day_cur == pco%int_day) then
          if (pco%hyd%d == "y") then
            if (cs_db%num_pests > 0) then        !! pests
              write (2740,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
               ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),  &
               ob(iob)%frac_out(iiout), (hcs1%pest(ipest), ipest = 1, cs_db%num_pests)
              if (pco%csvout == "y") then
                write (2756,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,  &
                  ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),              &
                  ob(iob)%frac_out(iiout), (hcs1%pest(ipest), ipest = 1, cs_db%num_pests)
              end if                             !! cvs pests
            end if                               !! pests

              if (cs_db%num_paths > 0) then      !! paths
                write (2744,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
                 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), &
                 ob(iob)%frac_out(iiout), (hcs1%path(ipath), ipath = 1, cs_db%num_paths)
              if (pco%csvout == "y") then
                write (2760,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,  &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),               &
                 ob(iob)%frac_out(iiout), (hcs1%path(ipath), ipath = 1, cs_db%num_paths)
              end if                            !! cvs paths
              end if                            !! paths

              if (cs_db%num_metals > 0) then    !! metals
                write (2748,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout), &
                 ob(iob)%frac_out(iiout), (hcs1%hmet(imetal), imetal = 1, cs_db%num_metals)
              if (pco%csvout == "y") then
                write (2764,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,  &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),               &
                 ob(iob)%frac_out(iiout), (hcs1%hmet(imetal), imetal = 1, cs_db%num_metals)
              end if                            !! cvs metals
              end if                            !! metals

              if (cs_db%num_salts > 0) then     !! salts
                write (2752,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),  &
                 ob(iob)%frac_out(iiout), (hcs1%salt(isalt), isalt = 1, cs_db%num_salts)
              if (pco%csvout == "y") then
                write (2768,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,  &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),               &
                 ob(iob)%frac_out(iiout), (hcs1%salt(isalt), isalt = 1, cs_db%num_salts)
              end if                            !! cvs salts
              end if                            !! salts
            end if
          end if

        obcs(iob)%hcsout_m(iiout) = obcs(iob)%hcsout_m(iiout) + hcs1

        !! monthly print
        if (time%end_mo == 1) then
          if (pco%hyd%m == "y") then
              if (cs_db%num_pests > 0) then        !! pests
                write (2741,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,     &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              if (pco%csvout == "y") then
                write (2757,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,  &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),               &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              end if                             !! cvs pests
            end if                               !! pests

              if (cs_db%num_paths > 0) then      !! paths
                write (2745,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,     &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              if (pco%csvout == "y") then
                write (2761,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              end if                            !! cvs paths
              end if                            !! paths

              if (cs_db%num_metals > 0) then    !! metals
                write (2749,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,       &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),     &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              if (pco%csvout == "y") then
                write (2765,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              end if                            !! cvs metals
              end if                            !! metals

              if (cs_db%num_salts > 0) then     !! salts
                write (2753,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              if (pco%csvout == "y") then
                write (2769,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_m(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              end if                            !! cvs salts
              end if                            !! salts
            end if
          end if

        obcs(iob)%hcsout_y(iiout) = obcs(iob)%hcsout_y(iiout) + obcs(iob)%hcsout_m(iiout)

        !! yearly print
        if (time%end_yr == 1) then
          if (pco%hyd%y == "y") then
            if (cs_db%num_pests > 0) then        !! pests
                write (2742,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,     &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              if (pco%csvout == "y") then
                write (2752,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              end if                             !! cvs pests
            end if                               !! pests

              if (cs_db%num_paths > 0) then      !! paths
                write (2746,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,      &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),    &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              if (pco%csvout == "y") then
                write (2762,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              end if                            !! cvs paths
              end if                            !! paths

              if (cs_db%num_metals > 0) then    !! metals
                write (2750,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,      &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),    &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              if (pco%csvout == "y") then
                write (2766,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              end if                            !! cvs metals
              end if                            !! metals

              if (cs_db%num_salts > 0) then     !! salts
                write (2754,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              if (pco%csvout == "y") then
                write (2770,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_y(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              end if                            !! cvs salts
              end if                            !! salts
           end if
          end if

        obcs(iob)%hcsout_a(iiout) = obcs(iob)%hcsout_a(iiout) + obcs(iob)%hcsout_y(iiout)

        !! average annual print
        if (time%end_sim == 1 .and. pco%hyd%a == "y") then
          ob(iob)%hin_a(iiout) = ob(iob)%hin_a(iiout) / time%yrs_prt
            if (cs_db%num_pests > 0) then        !! pests
                write (2743,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,     &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),   &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              if (pco%csvout == "y") then
                write (2759,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                 &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%pest(ipest), ipest = 1, cs_db%num_pests)
              end if                             !! cvs pests
            end if                               !! pests

              if (cs_db%num_paths > 0) then      !! paths
                write (2747,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),  &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              if (pco%csvout == "y") then
                write (2763,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%path(ipath), ipath = 1, cs_db%num_paths)
              end if                            !! cvs paths
              end if                            !! paths

              if (cs_db%num_metals > 0) then    !! metals
                write (2751,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,      &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),    &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              if (pco%csvout == "y") then
                write (2767,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%hmet(imetal), imetal = 1, cs_db%num_metals)
              end if                            !! cvs metals
              end if                            !! metals

              if (cs_db%num_salts > 0) then     !! salts
                write (2755,*) time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,    &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),  &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              if (pco%csvout == "y") then
                write (2771,'(*(G0.3,:","))') time%day, time%mo, time%day_mo, time%yrc, iob, ob(iob)%gis_id, ob(iob)%typ,   &
				 ob(iob)%num, ob(iob)%obtyp_out(iiout), ob(iob)%obtypno_out(iiout), ob(iob)%htyp_out(iiout),                &
                 ob(iob)%frac_out(iiout), (obcs(iob)%hcsout_a(iiout)%salt(isalt), isalt = 1, cs_db%num_salts)
              end if                            !! cvs salts
              end if                            !! salts
        end if

        end do   !! sp_ob%objs
      end do     !! ob(iob)%rcv_tot

      end subroutine hcsout_output


! { dg-do run }
! Tests the fix for PR27269 and PR27xxx.
! The former caused a segfault in trying to process
! module b, with an unused equivalence in a. The latter
! produced an assembler error due to multiple declarations
! for a module equivalence, when one of the variables was
! initialized, as M in module a.
!
module a
  integer, parameter :: dp = selected_real_kind (10)
  real(dp) :: reM, M = 1.77d0
  equivalence (M, reM)
end module a

module b
  use a, only : dp
end module b

  use a
  use b
  if (reM .ne. 1.77d0) STOP 1
  reM = 0.57d1
  if (M .ne. 0.57d1) STOP 2
end


text:
UPDATE: Davis The bunny departed the world back in June and he will be sorely missed. Sure, he chewed on everything, but he made Users/DeannaBrusco happy and could cheer her up as if he knew she was sad. So, let us remember little Davis the Bunny: he made the world a better place by making my friend happy. Users/MattJojola

Davis the bunny was originally named Mavis becasue his owner, Users/DeannaBrusco thought he was a female. Later, when he started humping everything in sight, she realized he was a male. She named him Davis because it rhymed and she didnt want to give him a complex.

Davis loves to chew on all of Deannas clothes, her cords, and recently chewed up her comforter. He likes to eat pizza, cheeseits, and carrots.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
        subroutine iddr_svd(m,n,a,krank,u,v,s,ier,r)
c
c       constructs a rank-krank SVD  u diag(s) v^T  approximating a,
c       where u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine combines a QR code
c       (which is based on plane/Householder reflections)
c       with the LAPACK routine dgesdd.
c
c       input:
c       m -- first dimension of a and u
c       n -- second dimension of a, and first dimension of v
c       a -- matrix to be SVD'd
c       krank -- desired rank of the approximation to a
c
c       output:
c       u -- left singular vectors of a corresponding
c            to the k greatest singular values of a
c       v -- right singular vectors of a corresponding
c            to the k greatest singular values of a
c       s -- k greatest singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero when the routine encounters an error
c
c       work:
c       r -- must be at least
c            (krank+2)*n+8*min(m,n)+15*krank**2+8*krank
c            real*8 elements long
c
c       _N.B._: This routine destroys a. Also, please beware that
c               the source code for this routine could be clearer.
c
        implicit none
        character*1 jobz
        integer m,n,k,krank,iftranspose,ldr,ldu,ldvt,lwork,
     1          info,j,ier,io
        real*8 a(m,n),u(m,krank),v(n*krank),s(krank),r(*)
c
c
        io = 8*min(m,n)
c
c
        ier = 0
c
c
c       Compute a pivoted QR decomposition of a.
c
        call iddr_qrpiv(m,n,a,krank,r,r(io+1))
c
c
c       Extract R from the QR decomposition.
c
        call idd_retriever(m,n,a,krank,r(io+1))
c
c
c       Rearrange R according to ind (which is stored in r).
c
        call idd_permuter(krank,r,krank,n,r(io+1))
c
c
c       Use LAPACK to SVD R,
c       storing the krank (krank x 1) left singular vectors
c       in r(io+krank*n+1 : io+krank*n+krank*krank).
c
        jobz = 'S'
        ldr = krank
        lwork = 2*(3*krank**2+n+4*krank**2+4*krank)
        ldu = krank
        ldvt = krank
c
        call dgesdd(jobz,krank,n,r(io+1),ldr,s,r(io+krank*n+1),ldu,
     1              v,ldvt,r(io+krank*n+krank*krank+1),lwork,r,info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c       Multiply the U from R from the left by Q to obtain the U
c       for A.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = r(io+krank*n+j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        iftranspose = 0
        call idd_qmatmat(iftranspose,m,n,a,krank,krank,u,r)
c
c
c       Transpose v to obtain r.
c
        call idd_transer(krank,n,v,r)
c
c
c       Copy r into v.
c
        do k = 1,n*krank
          v(k) = r(k)
        enddo ! k
c
c
        return
        end
c
c
c
c

max_issues_repo_name: birichie/catboost

max_forks_repo_name: birichie/catboost


text:
      PROGRAM CCPCFX
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (M=40,N=40,LRWK=3500,LIWK=4000)
      REAL Z(M,N), RWRK(LRWK)
      INTEGER IWRK(LIWK)

      CALL GETDAT (Z, M, N)
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
      CALL GSCLIP (0)
C
C Initialize Conpack
C
      CALL CPSETR('CFX - CONSTANT FIELD LABEL X',0.)
      CALL CPSETR('CFY - CONSTANT FIELD LABEL Y',1.)
      CALL CPSETI('CFP - CONSTANT FIELD POSITION FLAG',2)
      CALL CPRECT(Z, M, M, N, RWRK, LRWK, IWRK, LIWK)
C
C Draw Perimeter
C
      CALL CPBACK(Z, RWRK, IWRK)
C
C Draw Contours
C
      CALL CPLBDR(Z,RWRK,IWRK)
      CALL CPCLDR(Z,RWRK,IWRK)
C
C Close frame
C
      CALL FRAME
C
C Deactivate and close workstation, close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS

      STOP
      END

      SUBROUTINE GETDAT (Z, M, N)
      INTEGER I,J,M,N
      REAL Z(M,N)

      DO 10, I=1,M
         DO 20, J=1,N
            Z(I,J)=13.0
 20      CONTINUE
 10   CONTINUE

      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:20 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE SAVE_STATIONS_FILE__genmod
          INTERFACE
            SUBROUTINE SAVE_STATIONS_FILE(NRECEIVERSETS,NREC,XDEB,ZDEB, &
     &XFIN,ZFIN,RECORD_AT_SURFACE_SAME_VERTICAL,XINTERFACE_TOP,         &
     &ZINTERFACE_TOP,COEFS_INTERFACE_TOP,NPOINTS_INTERFACE_TOP,         &
     &MAX_NPOINTS_INTERFACE)
              INTEGER(KIND=4) :: MAX_NPOINTS_INTERFACE
              INTEGER(KIND=4) :: NRECEIVERSETS
              INTEGER(KIND=4) :: NREC(NRECEIVERSETS)
              REAL(KIND=8) :: XDEB(NRECEIVERSETS)
              REAL(KIND=8) :: ZDEB(NRECEIVERSETS)
              REAL(KIND=8) :: XFIN(NRECEIVERSETS)
              REAL(KIND=8) :: ZFIN(NRECEIVERSETS)
              LOGICAL(KIND=4) :: RECORD_AT_SURFACE_SAME_VERTICAL(       &
     &NRECEIVERSETS)
              REAL(KIND=8) :: XINTERFACE_TOP(MAX_NPOINTS_INTERFACE)
              REAL(KIND=8) :: ZINTERFACE_TOP(MAX_NPOINTS_INTERFACE)
              REAL(KIND=8) :: COEFS_INTERFACE_TOP(MAX_NPOINTS_INTERFACE)
              INTEGER(KIND=4) :: NPOINTS_INTERFACE_TOP
            END SUBROUTINE SAVE_STATIONS_FILE
          END INTERFACE
        END MODULE SAVE_STATIONS_FILE__genmod


text:
! ==============================================================================
!
!> \file
!> \brief   Contains the implementation of \c describeTarget
!> \author  CMJ, XCP-3 (LANL)
!
!  PROCEDURE DESCRIPTION:
!
!> \fn     describeTarget
!> \brief  Writes the attributes of the target to an output stream
!
!> Writes the attributes of the target object to an output stream. Clients
!> may provide an output stream to the procedure, however it will be validated
!> prior to being utilized.
!> The default output stream is to terminal (\c output_unit)
!
!  ARGUMENTS:
!> \param[in   ] targ          the target to be described
!> \param[in   ] ioStream      the unit number (int32) to write to (opt.)
!
! ==============================================================================

  subroutine describeTarget(targ, ioStream)

      use, intrinsic:: iso_fortran_env, only: int32, real64, output_unit

      implicit none
      class(gsmTarget), intent(in   ) :: targ
      integer(int32),   intent(in   ), optional :: ioStream

      integer(int32) :: stream = output_unit   !< The actual stream variable

! ==============================================================================

      ! Set stream
      if (present(ioStream)) then
         stream = getValidIOStream(ioStream)
      end if

      ! Describe attributes:
      write(stream, 1000) &
         & trim(adjustl(targ%particleName)), &
         & targ%numBaryons, &
         & targ%numProtons, &
         & targ%restMass, &
         & targ%afMultiplier, &
         & targ%czMultiplier

      return
! ==============================================================================
1000 format(/, &
          & /5x, "TARGET '", A, "':", &
          & /5x, "--------------------------------------", &
          & /5x, "A    = ", f5.1, &
          & /5x, "Z    = ", f5.1, &
          & /5x, "E_0  = ", f8.3, " [GeV/c**2]", &
          & /5x, "A_f  = ", f6.3, &
          & /5x, "C_z  = ", f6.3)
! ==============================================================================
  end subroutine describeTarget

max_stars_repo_name: lanl/generalized-spallation-model

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_name: lanl/generalized-spallation-model

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_name: lanl/generalized-spallation-model

max_forks_repo_licenses: Intel Unlicense


text:
C  =====================================================================
C  pgm: SHSAVQ .. Buffer and save/restore qualifier code
C
C  use:      CALL SHSAVQ(CMD,ITEM,KWAL)
C
C   in: CMD ....... routine command to save or retrieve code - CHAR*1
C   in:               'I' ... Initialize buffer qualifier code to 'Z'
C   in:               'P' ... Put qualifier code in buffer
C   in:               'G' ... Get qualifier code from buffer
C   in:               'S' ... Save buffer qualifier code in array
C   in:               'R' ... Restore buffer qualifier code from array
C   in: ITEM ...... field number of code to save or retrieve - INT
C  i/o: KWAL ...... one character qualifier code - CHAR*1
C
C  cmt: Hardwired for 200 fields (or items).
C  =====================================================================
      SUBROUTINE SHSAVQ(CMD,ITEM,KWAL)

      CHARACTER*1   CMD,KWAL,SVKWAL,SVARRQ(200)
      INTEGER       ITEM,II

      SAVE          SVKWAL,SVARRQ
C
C    ================================= RCS keyword statements ==========
      CHARACTER*68     RCSKW1,RCSKW2
      DATA             RCSKW1,RCSKW2 /                                 '
     .$Source: /fs/hseb/ob5/rfc/ofs/src/shefpars_driv/RCS/shsavq.f,v $
     . $',                                                             '
     .$Id: shsavq.f,v 1.2 1997/12/31 20:51:27 page Exp $
     . $' /
C    ===================================================================
C

      DATA          SVKWAL / 'Z' /

        IF (CMD .EQ. 'I') THEN
            SVKWAL = 'Z'

        ELSEIF (CMD .EQ. 'P') THEN
            SVKWAL = KWAL

        ELSEIF (CMD .EQ. 'G') THEN
            KWAL = SVKWAL

        ELSEIF (CMD .EQ. 'S') THEN
             II = ITEM
            SVARRQ(II) = SVKWAL

        ELSEIF (CMD .EQ. 'R') THEN
             II = ITEM
            SVKWAL = SVARRQ(II)

        ENDIF

      RETURN
      END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
Describe Users/PaulBennick here.

Hi Paul! Welcome to the wiki Thanks for the update on action signs!


text:
Name:
Nathanial Ofiesh

Phone Number:
(916) 4175157
(916) 2880575
nathan@uhdavis.com

Office:
Internet Sales Manager
University Honda
4343 Chiles Road
Davis, CA 95618
(530) 7588770
www.universityhonda.com


text:
<ompts:test>
<ompts:testdescription>Test which checks the omp barrier directive. The test    creates several threads and sends one of them sleeping before setting a flag.  After the barrier the other ones do some littel work depending on the flag.</   ompts:testdescription>
<ompts:ompversion>2.0</ompts:ompversion>
<ompts:directive>omp barrier</ompts:directive>
<ompts:testcode>

      SUBROUTINE do_some_work3()
        REAL i
        INTRINSIC sqrt
        DOUBLE PRECISION sum
        INCLUDE "omp_testsuite.f"
        sum = 0.0
        DO WHILE (i < LOOPCOUNT-1)
          sum = sum + sqrt(i)
          i = i + 1
        END DO
      END

      INTEGER FUNCTION <ompts:testcode:functionname>omp_barrier</ompts:testcode:functionname>()
        IMPLICIT NONE
        INTEGER sleeptime
        INTEGER omp_get_thread_num
        INTEGER result1, result2, rank
        result1 = 0
        result2 = 0
        sleeptime = 1
!$omp parallel private(rank)
        rank = omp_get_thread_num()
!        PRINT *, "rank", rank
        IF ( rank .EQ. 1 ) THEN
          CALL sleep(sleeptime)
          result2 = 3
        END IF
        <ompts:orphan>
        <ompts:check>
!$omp barrier
        </ompts:check>
        </ompts:orphan>
        IF ( rank .EQ. 0 ) THEN
          result1 = result2
        END IF
!$omp end parallel
        IF ( result1 .EQ. 3 ) THEN
           <testfunctionname></testfunctionname> = 1
        ELSE
           <testfunctionname></testfunctionname> = 0
        END IF
      END
</ompts:testcode>
</ompts:test>

max_stars_repo_name: natgla/omp-validation

max_issues_repo_name: pulidocr/omp-validation

max_forks_repo_name: pulidocr/omp-validation


MODULE module_rectangle

    IMPLICIT NONE

CONTAINS

    REAL FUNCTION rectagle_area( side_a_length , side_b_length )
        IMPLICIT NONE
        REAL, INTENT(IN) :: side_a_length
        REAL, INTENT(IN) :: side_b_length

        rectagle_area=side_a_length*side_b_length
    END FUNCTION

    REAL FUNCTION rectagle_perimeter( side_a_length , side_b_length )
        IMPLICIT NONE
        REAL, INTENT(IN) :: side_a_length
        REAL, INTENT(IN) :: side_b_length

        rectagle_perimeter=2*side_a_length+2*side_b_length
    END FUNCTION

END MODULE module_rectangle


!      Crystal Plasticity Input File Generator for Abaqus Standard
!
!      5/7/00 - 	Only valid for FCC structure
!               	Only Asaro hardening model implemented
!               	Only valid for isotropic elastic properties
!               	Latent hardening parameters (Q1, Q2) set to (1, 0)
!	   30/08/11 - 	Modified by JGROGAN. Removed some seldom used choices
!					and added new random generator due to potential
!					problems with previous 'RANDU' type generator.(igen)
!					Added gen plane strain option (igps)
!
!      Use odd number as seed for random number generator
!
!      NLGEOM flag automatically assumed
!      Newton-raphson iteration scheme and default parameters inputted
!
! ******************************************************************
	program matgen
        integer ncrys,iseed
		character(1) filename
		character(len=256)input2(2)
		integer seed(1)
        real*8 E,mu,g0,ginf,h0,adot,n,thick
! ******************************************************************
		ncrys=300
		nfiles=5
        thick=0.1
		E=193000.
		mu=0.3
		g0=150.
		ginf=360.
		h0=380.
        adot=0.0106
		n=50.
        iseed=830963 !ori1
		iseed=211327  !ori2
		iseed=312099  !ori3
		iseed=98247  !ori4
		iseed=446725  !ori5
		iseed=504991  !ori6
		iseed=493487  !ori7
		iseed=902013  !ori8
		iseed=363209  !ori9
		iseed=418743  !ori10
		iseed=647832 !ori11
		iseed=921647832 !ori12
		seed=iseed
		call random_seed(put=seed)
		igen=2
		istan=0
		igps=0
		do i=1,nfiles
			write(filename,'(i1)')i
			open(unit=11,status='unknown',file='W1L80ST.inp')
			open(unit=10,status='unknown',file='W1L80STP_'//trim(filename)//'.inp')
			input2(1)='**'
			do while (index(input2(1),'*End Assembly')==0)
				read(11,'(a)')input2(2)
				write(10,'(a)')input2(1)
				input2(1)=input2(2)
			enddo
			write(10,'(a)')'*End Assembly'
! ******************************************************************
			do icrys=1,ncrys
				write(10,'(a)') '**'
				write(10,'(a,i5)')'*MATERIAL, NAME=MAT',icrys
				write(10,'(a)')'**'
				write(10,'(a)')'*elastic'
				write(10,'(f16.4,a,f6.4)')E,',',mu
				call random_number(rand1)
				rh=800.
				if (rand1<0.1)rh=500.
				write(10,'(a)')'*plastic'
				stran=0.
				do j=1,50
					stress=350.+(rh-350.)*tanh(abs(1200.*stran/(rh-350.)))
					write(10,'(f16.4,a,f6.4)')stress,',',stran
					stran=stran+0.01
				enddo
				write(10,'(a)')'**'
			enddo
			ierr=0
			do while (ierr==0)
				read(11,'(a)',iostat=ierr)input2(1)
				if(ierr==0)write(10,'(a)')input2(1)
			enddo
			close(unit=10)
			close(unit=11)
		enddo
	end program matgen


use EarthClass
implicit none

type(Earth_) :: Earth

call earth%init()

call earth%setTimeZone(name="Tokyo")
earth%MyPosition = [36.380d0, 140.470d0]
earth%Year   = 2022
earth%Month  = 7
earth%Day    = 1
earth%Hour   = 12
earth%minute = 0
earth%second = 0

print *, earth%getSunPosition()

end


text:
*----------------------------------------------------------------------*
      subroutine reorder_formula(form,op_info)
*----------------------------------------------------------------------*
*     reorder formula
*     a) group all contributions to one result block
*     b) ... further reodering .... ?
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'
      include 'opdim.h'
      include 'def_contraction.h'
      include 'mdef_operator_info.h'
      include 'def_formula_item.h'
      include 'def_formula_item_list.h'

      integer, parameter ::
     &     ntest = 00

      type(formula_item), intent(inout), target ::
     &     form
      type(operator_info), intent(in) ::
     &     op_info

      integer ::
     &     idx_tgt, iblk_tgt, nblk, nfound
      type(formula_item), pointer ::
     &     form_pnt
      type(formula_item_list), target ::
     &     fpl_reo
      type(formula_item_list), pointer ::
     &     fpl_reo_pnt

      if (ntest.ge.100) then
        write(lulog,*) '========================='
        write(lulog,*) ' reorder_formula at work'
        write(lulog,*) '========================='
      end if

      if (form%command.eq.command_end_of_formula) return
      idx_tgt = form%target

      if (idx_tgt.gt.0) then
        nblk = op_info%op_arr(idx_tgt)%op%n_occ_cls
      else
        nblk = 1
      end if

      if (nblk.gt.1) then

        call init_formula_plist(fpl_reo)
        fpl_reo_pnt => fpl_reo
        ! keep [INIT]
        if (form%command.ne.command_add_contribution) then
          fpl_reo_pnt%item => form
        end if

        tgt_loop: do iblk_tgt = 1, nblk
          ! look for first term which contributes to this block
          form_pnt => form
          if (form_pnt%command.ne.command_add_contribution) then
            form_pnt => form_pnt%next
          end if
          search: do
            if (form_pnt%command.ne.command_add_contribution)
     &         cycle tgt_loop
            if (form_pnt%target.ne.idx_tgt .or.
     &           form_pnt%contr%idx_res.ne.idx_tgt) then
              write(lulog,*) 'idx_tgt, target, idx_res:',
     &             idx_tgt, form_pnt%target, form_pnt%contr%idx_res
              call quit(1,'reorder_formula',
     &             'suspicious change of target')
            end if
            if (form_pnt%contr%iblk_res.eq.iblk_tgt) exit search
            form_pnt => form_pnt%next
          end do search
          ! get a new enty on pointer list
          if (associated(fpl_reo_pnt%item)) then
            call new_formula_plist_entry(fpl_reo_pnt)
            fpl_reo_pnt => fpl_reo_pnt%next
          end if
          ! collect pointers to all contributions with same block
          call collect_contr2block(fpl_reo_pnt,nfound,form_pnt,op_info)
          ! advance pointer
          do while(associated(fpl_reo_pnt%next))
            fpl_reo_pnt => fpl_reo_pnt%next
          end do
          if (ntest.ge.100) then
            write(lulog,*) 'iblk, # terms: ',iblk_tgt,nfound
          end if
        end do tgt_loop

        ! let last fpl_reo element point to [END] of form
        form_pnt => form
        do while(associated(form_pnt%next))
          form_pnt => form_pnt%next
        end do
        if (form_pnt%command.eq.command_end_of_formula) then
          call new_formula_plist_entry(fpl_reo_pnt)
          fpl_reo_pnt => fpl_reo_pnt%next
          fpl_reo_pnt%item => form_pnt
        end if

        call relink_formula_list(form,fpl_reo)

        call dealloc_formula_plist(fpl_reo)

        if (ntest.ge.100) then
          call print_form_list(lulog,form,op_info)
        end if

      end if

      return
      end

max_stars_repo_name: ak-ustutt/GeCCo-public

max_issues_repo_name: ak-ustutt/GeCCo-public

max_forks_repo_name: ak-ustutt/GeCCo-public