text:
*----------------------------------------------------------------------*
      subroutine frm_sched2(xret,flist,depend_info,idxselect,nselect,
     &         init,no_skip,op_info,str_info,strmap_info,orb_info)
*----------------------------------------------------------------------*
*     schedule the evaluation of a formula
*
*     version 2 -- for new optimized formulae
*----------------------------------------------------------------------*

      implicit none

      include 'routes.h'

      include 'opdim.h'
      include 'stdunit.h'
      include 'ioparam.h'
      include 'def_orbinf.h'
      include 'mdef_operator_info.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_contraction.h'
      include 'def_formula_item.h'
      include 'par_opnames_gen.h'
      include 'def_reorder_info.h'
      include 'def_dependency_info.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest =  000

      character, parameter ::
     &     name_scr0*6 = 'cntscr'

      character ::
     &     name_scr*13

      real(8), intent(inout) ::
     &     xret(*)
      integer, intent(in) ::
     &     nselect, idxselect(nselect)
      logical, intent(in) ::
     &     init, no_skip
      type(formula_item), intent(in), target ::
     &     flist
      type(operator_info), intent(inout) ::
     &     op_info
      type(strinf) ::
     &     str_info
      type(strmapinf) ::
     &     strmap_info
      type(orbinf) ::
     &     orb_info
      type(dependency_info) ::
     &     depend_info

      logical ::
     &     update, add, reo, skip, call_sti_remover, measure
      integer ::
     &     idxopres, idxres, nres, type_xret,
     &     idxme_res, nblk_res, ifree,
     &     iterm, icmd, icmd_pfi, iprint
      real(8) ::
     &     xret_last

      type(me_list_array), pointer ::
     &     mel_arr(:)
      real(8), pointer ::
     &     xret_blk(:), xret_pnt(:)
      real(8), target ::
     &     xret_scr(1)
      integer, pointer ::
     &     op2list(:)
      type(operator), pointer ::
     &     opres
      type(me_list), pointer ::
     &     me_res
      type(filinf), pointer ::
     &     ffres
      type(formula_item), pointer ::
     &     cur_form

      real(8) ::
     &     cpu, sys, wall, cpu0, sys0, wall0,
     &     cpus,syss,walls,cpus0,syss0,walls0

      integer, external ::
     &     idxlist, idx_oplist2
      logical, external ::
     &     me_list_uptodate

      ifree = mem_setmark('frm_sched0')

      iprint = max(ntest,iprlvl)
      if (ntest.gt.10.or.iprint.ge.20) then
        write(lulog,*) '============================='
        write(lulog,*) '= Entered formula scheduler ='
        write(lulog,*) '============================='
      end if

      mel_arr => op_info%mel_arr
      op2list => op_info%op2list

      cur_form => flist

      skip = .false.
      nres  = 0
      idxres = 0
      iterm = 0
      icmd = 0
      icmd_pfi = 0 ! only for ntest.ge.100
      nullify(xret_blk)
      xret_last = 0d0

      ! loop over entries
      main_loop: do

        if (lustat.gt.0) call atim_csw(cpus0,syss0,walls0)
        measure = .false.

        if (nres.eq.0 .and.
     &      cur_form%command.ne.command_set_target_init)
     &     call quit(1,'frm_sched2','first command must define target')

        update = .false.
        call_sti_remover = .false.

        if (ntest.ge.100)
     &       call print_form_item(lulog,icmd_pfi,cur_form,op_info)

        select case(cur_form%command)
        case(command_end_of_formula,command_set_target_init)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case end and set"
cdbg end
          ! set pointers again, as the targets may change
          mel_arr => op_info%mel_arr
          op2list => op_info%op2list

          ! for previous target: assemble xret value
          if (idxres.gt.0.and..not.skip) then

            ! spin projections: either full or only spin-flip symmetry
            if (me_res%s2.ge.0) then
              call spin_prj_list(1d0,me_res,me_res,-1,
     &             xret_blk,.true.,
     &             op_info,str_info,strmap_info,orb_info)
            ! in case of splin-flip symmetry exploitation:
            ! symmetrize final result here (if not scalar)
            else if (use_tr.and.me_res%absym.ne.0.and.type_xret.eq.1)
     &      then
              call sym_ab_list(0.5d0,me_res,me_res,
     &             xret_blk,.true.,
     &             op_info,str_info,strmap_info,orb_info)
            end if

            if (type_xret.eq.1) then
              xret(idxres) = sqrt(sum(xret_blk(1:nblk_res)))
            else if (type_xret.eq.2) then
              xret(idxres) = xret_blk(1)
            end if

            call atim_csw(cpu,sys,wall)
            call prtim(lulog,'time for target '//trim(opres%name),
     &           cpu-cpu0,sys-sys0,wall-wall0)
!            if (luout.ne.lulog)
!     &      call prtim(luout,'time for target '//trim(opres%name),
!     &           cpu-cpu0,sys-sys0,wall-wall0)

          end if

          call atim_csw(cpu0,sys0,wall0)

          if (cur_form%command.eq.command_end_of_formula)
     &         exit main_loop

          xret_last = 0d0

          ! initialize result
          nres = nres+1
          idxres = nres

          ! requested?
          skip = nselect.gt.0.and.
     &           idxlist(idxres,idxselect,nselect,1).le.0
          ! check dependency
c          skip = skip.or.me_list_uptodate(idxres,depend_info,op_info)

          skip = skip.or.
     &           ((.not.no_skip).and.init
     &             .and.me_list_uptodate(idxres,depend_info,op_info))

          idxopres = cur_form%target      ! op index of result

          idxme_res = op2list(idxopres)  ! list index of result
          if (iprint.ge.10.and.skip) then
            write(lulog,*) 'Skipping target: ',
     &           trim(mel_arr(idxme_res)%mel%label)
          else if (iprint.ge.10) then
            write(lulog,*) 'New target: ',
     &           trim(mel_arr(idxme_res)%mel%label)
          end if

          if (skip) then
            ! fast-forward to next [init target]
            do while(
     &           cur_form%next%command.ne.command_set_target_init.and.
     &           cur_form%next%command.ne.command_end_of_formula)
              cur_form => cur_form%next
            end do

          else

            me_res => op_info%mel_arr(idxme_res)%mel
            opres  => me_res%op
            ffres  => me_res%fhand
            nblk_res = opres%n_occ_cls
            type_xret = 2
            if (me_res%len_op.gt.1) type_xret = 1
            if (ffres%unit.le.0)
     &           call file_open(ffres)
            if (init) call zeroop(me_res)

            if (lustat.gt.0) write(lustat,*) 'NEW TARGET: ',
     &           trim(me_res%label)

            if (associated(xret_blk))
     &           ifree = mem_dealloc('xret_blk')
            ifree = mem_alloc_real(xret_blk,nblk_res,'xret_blk')
            xret_blk(1:nblk_res) = 0d0

            ! mark current term as updated:
            call touch_file_rec(ffres)

          end if

        case(command_new_intermediate)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case new int"
cdbg end
          call fs_newintm_drv(cur_form,
     &         op_info,str_info,strmap_info,orb_info)

        case(command_del_intermediate)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case del int"
cdbg end
          call fs_delintm_drv(cur_form,op_info)

        case(command_reorder,command_add_reo)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case reo, add reo"
cdbg end
          measure = .true.
          !update = cur_form%command.eq.command_add_reo
          update = idx_oplist2(cur_form%reo%label_out,op_info)
     &                 .eq.idxopres
          add    = cur_form%command.eq.command_add_reo
          if (cur_form%command.eq.command_add_reo) icmd = icmd+1
          call fs_reo_drv(xret_blk,type_xret,idxopres,me_res,
     &         cur_form,update,add,
     &         op_info,str_info,strmap_info,orb_info)

          call_sti_remover = .true.!cur_form%command.eq.command_reorder

        case(command_add_intm,command_cp_intm)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case add int cp int"
cdbg end
          measure = .true.
          icmd = icmd+1
          !update = cur_form%command.eq.command_add_intm
          update = idx_oplist2(cur_form%bcontr%label_res,op_info)
     &                 .eq.idxopres

          call fs_add_drv(xret_blk,type_xret,idxopres,me_res,
     &         cur_form,update,
     &         op_info,str_info,strmap_info,orb_info)

          call_sti_remover = .true.

        case(command_bc,command_add_bc,
     &       command_bc_reo,command_add_bc_reo)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case bc stuffs"
cdbg end
          measure = .true.
          icmd = icmd+1
          add    = (cur_form%command.eq.command_add_bc.or.
     &              cur_form%command.eq.command_add_bc_reo)
          update = idx_oplist2(cur_form%bcontr%label_res,op_info)
     &                 .eq.idxopres
          reo    = (cur_form%command.eq.command_bc_reo.or.
     &              cur_form%command.eq.command_add_bc_reo)

          call fs_contr_drv(xret_blk,
     &                             type_xret,idxopres,me_res,
     &         cur_form,update,add,reo,
     &         op_info,str_info,strmap_info,orb_info)

          call_sti_remover = .true.

        case(command_symmetrise)

c dbg
c         write(lulog,*) "DBG info frm_sched2: case symm"
cdbg end
          measure = .true.
          call symmetrise(1d0,me_res,me_res,
     &         xret_blk,
     &         op_info,str_info,orb_info)

        case(command_psinv,command_inv)

          measure = .true.
c          call inv_op()
          call quit(1,'frm_sched2','[PS_INV], [INV] are not yet fit!')

        case(command_add_contribution)
          call quit(1,'frm_sched2',
     &       'command not valid in this version of frm_sched!: [CONTR]')

        case default
          write(lulog,*) 'command = ',cur_form%command
          call quit(1,'frm_sched2','command not defined/implemented')
        end select

        ! remove short-term intermediates
        if (call_sti_remover)
     &       call fs_sti_remover(cur_form,op_info)

        if (update) then
          ! we count only terms that actually update a target
          iterm = iterm + 1
          if (type_xret.eq.2.and.iprint.ge.3)
     &         write(lulog,'(1x,"term # ",i5,":",2(x,g19.10))')
     &         iterm, xret_blk(1)-xret_last, xret_blk(1)
          if (type_xret.eq.2) xret_last = xret_blk(1)

          if (ntest.ge.50) then
            write(lulog,*) 'xret after term ',iterm
            write(lulog,'(x,4f19.10)') xret_blk(1:nblk_res)
          end if
        end if

        if (lustat.gt.0.and.measure) then
          call atim_csw(cpus,syss,walls)
          write(lustat,'(i8,3f18.4)')
     &         icmd,cpus-cpus0,syss-syss0,walls-walls0
        end if

        if (.not.associated(cur_form%next))
     &       call quit(1,'frm_sched2',
     &       'unexpected end of formula list ([END] missing)')

        cur_form => cur_form%next

      end do main_loop

      ifree = mem_flushmark()

      if (ntest.ge.100)
     &     write(lulog,*) 'returning from frm_sched2'

      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


text:
Name: Debbie Pattison

School: DaVinci High School DaVinci High

Debbi is this awesome person who ought to make a wiki page for herself.  The end.

20051115 08:49:17 nbsp debbie patison is often times a pomegranite ghost. Users/NoraSandstedt

20051204 22:45:24 nbsp someone should put up the pomegranite picture. I dont have it. oh, the woe.. Users/AubreyJohnson

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!* Copyright (c) Lawrence Livermore National Security, LLC and other Conduit
!* Project developers. See top-level LICENSE AND COPYRIGHT files for dates and
!* other details. No copyright assignment is required to contribute to Conduit.

!------------------------------------------------------------------------------
!
! t_f_relay_smoke.f
!
!------------------------------------------------------------------------------

!------------------------------------------------------------------------------
module t_f_relay_smoke
!------------------------------------------------------------------------------

  use iso_c_binding
  use fruit
  use conduit
  use conduit_relay
  implicit none

!------------------------------------------------------------------------------
contains
!------------------------------------------------------------------------------

!------------------------------------------------------------------------------
! About test
!------------------------------------------------------------------------------

    !--------------------------------------------------------------------------
    subroutine t_relay_about
        type(C_PTR) cnode
        integer res

        !----------------------------------------------------------------------
        call set_case_name("t_blueprint_about")
        !----------------------------------------------------------------------

        cnode = conduit_node_create()
        call conduit_relay_about(cnode)
        call conduit_node_print(cnode)
        call conduit_node_destroy(cnode)

    end subroutine t_relay_about

!------------------------------------------------------------------------------
end module t_f_relay_smoke
!------------------------------------------------------------------------------

!------------------------------------------------------------------------------
program fortran_test
!------------------------------------------------------------------------------
  use fruit
  use t_f_relay_smoke
  implicit none
  logical ok

  call init_fruit

  !----------------------------------------------------------------------------
  ! call our test routines
  !----------------------------------------------------------------------------
  call t_relay_about

  call fruit_summary
  call fruit_finalize
  call is_all_successful(ok)

  if (.not. ok) then
     call exit(1)
  endif

!------------------------------------------------------------------------------
end program fortran_test
!------------------------------------------------------------------------------

max_stars_repo_name: adrienbernede/conduit

max_issues_repo_name: adrienbernede/conduit

max_forks_repo_name: adrienbernede/conduit


text:
c --- Author: D. Waters, September 2002
c --- Event buffer, used during unweighting to store
c --- the unweighted events generated during a single
c --- VEGAS pass.
      integer buffersize
      parameter(buffersize=10000)
      integer numstored,numused
      double precision eventbuffer(buffersize,mxpart,4)
      double precision wtbuffer(buffersize)
      integer indexlist(buffersize)
      integer pflavbuffer(buffersize),pbarflavbuffer(buffersize)
      common/eventlist/numstored,numused,eventbuffer,wtbuffer,indexlist,
     +     pflavbuffer,pbarflavbuffer

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
C    @(#)save_ged.f	20.18 8/30/00

C****************************************************************
C
C     File: save_ged.f
C
C     Purpose: Routine to save a network data file in GE format
C
C     / LOAD_GE, FILE = <filename>, -
C                TRNFILE = <filename>, -
C                VERSION = <number>
C                NEWTRNFILE = <filename>
C
C     Author: Walt Powell  Date: 21 May 1996
C     Called by: ctlpow.f
C
C****************************************************************
      integer function save_ged (scrfil, filename, version, option,
     &                           brdatafile, datebr, extfil,
     &                           extfilename, error)
      integer scrfil, error, version, extfil
      character *(*) filename, option(10), brdatafile, datebr,
     &               extfilename

      include 'ipfinc/parametr.inc'

      include 'ipfinc/blank.inc'
      include 'ipfinc/pti_data.inc'
      include 'ipfinc/filnam.inc'
      include 'ipfinc/jobctl.inc'
      include 'ipfinc/lfiles.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/alpha.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/area.inc'
      include 'ipfinc/arcntl.inc'
      include 'ipfinc/coment.inc'
      include 'ipfinc/header.inc'
      include 'ipfinc/basval.inc'

      common /bpa_num / user_rule, num_area_rule, num_zone_rule,
     &                  num_owner_rule, num_default_rule,
     &                  area_rule(3,MAXCAR), zone_rule(3,MAXZON),
     &                  owner_rule(3,MAXOWN), default_rule(2,100),
     &                  owner_code_ge(MAXOWN)
      integer user_rule, num_area_rule, num_zone_rule, num_owner_rule,
     &        num_default_rule, area_rule, zone_rule, owner_rule,
     &        default_rule
      character owner_code_ge*4

      common /verify_pti/ num_verify, hash_verify(PTI_HASHSIZE),
     &                    next_verify(PTI_MAXBUS),
     &                    ptinum_verify(PTI_MAXBUS),
     &                    bpanum_verify(PTI_MAXBUS)
      integer num_verify, hash_verify, next_verify, ptinum_verify,
     &                    bpanum_verify
      integer ext_geb, ext_gel, ext_geg, ext_geld, ext_geshn,
     &        ext_gesvd, ext_gear, ext_gezon, ext_gedcb, ext_gedcl,
     &        ext_gedcc, ext_gezdt, ext_geown, total(4),
     &        write_ge_file, status, gtge_num, fnd_ptiy, add_ptiz,
     &        fnd_ptio, fnd_ptiq, add_ptio, ftn_atoi, winter_type,
     &        ext_getrx
      character month(12)*3, xbuf*512, weekday(7)*3, winter_code(3)*18,
     &          userid*10, season_code(4)*10
      logical found

      data month / 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul',
     &             'Aug', 'Sep', 'Oct', 'Nov', 'Dec' /
      data weekday / 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' /

      data winter_code / 'Winter', 'Moderate Winter',
     &                   'Extra Heavy Winter' /

      data season_code / 'Summer', 'Winter', 'Spring', 'Fall' /

      save_ged = 0        ! set default return status = successful
      error = 0           ! initialize error count
      winter_type = index ('NME', option(7))
c
c     Initialize hash arrays to capture duplicate numbers of buses
c     actually used
c
      num_verify = 0
      do i = 1, PTI_MAXBUS
        ptinum_verify(i) = 0
        bpanum_verify(i) = 0
        next_verify(i) = 0
      enddo
      do i = 1, PTI_HASHSIZE
        hash_verify(i) = 0
      enddo

      if (option(4) .eq. 'Y' .or. option(5) .eq. 'Y') then
c
c       Option(*)  Supersede
c          (4)     GE bus-zones pairs with BPA bus-zones pairs
c          (5)     GE bus-owner pairs with BPA bus-owner pairs
c
        do ib = 1, ntot_alf
          nb = alf2inp(ib)
c
c         Get GE area, zone, owner, and bus number
c
          status = gtge_num (nb, iptia, iptiz, iptib)
          if (option(4) .eq. 'Y') then
            if (iptiz .eq. 0) then
              found = .false.
            else if (pti_znam(iptiz) .ne. zone(nb)) then
              found = .false.
            else
              found = .true.
            endif
            if (.not. found) then
              iptiz_new = fnd_ptiy (zone(nb))
              if (iptiz_new .eq. 0) then
                last = 0
                do i = 1, num_znam
                  last = max0 (pti_znum(i), last)
                enddo
                iptiz_new = add_ptiz (zone(nb), last+1)
              endif
              if (iptiz_new .gt. 0) then
                pti_zone(iptib) = pti_znum(iptiz_new)
              endif
            endif
          endif
          if (option(5) .eq. 'Y') then
            iptio = fnd_ptio (pti_owner(iptib))
            if (iptio .eq. 0) then
              found = .false.
            else if (pti_onam(iptio) .ne. owner(nb)) then
              found = .false.
            else
              found = .true.
            endif
            if (.not. found) then
              iptio_new = fnd_ptiq (owner(nb))
              if (iptio_new .eq. 0) then
                last = 0
                do i = 1, num_onam
                  last = max0 (pti_onum(i), last)
                enddo
                iptio_new = add_ptio (last+1, owner(nb))
              endif
              if (iptio_new .gt. 0) then
                pti_owner(iptib) = pti_onum(iptio_new)
              endif
            endif
          endif
        enddo
      endif
c
c     Write "#" records
c
      if (index (cspare(30), char(0)) .eq. 1 .or.
     &    cspare(30) .eq. ' ') cspare(30) = 'data'
      call nx_date (imon, idate, iyear, iwk_day)
      if (iyear .lt. 40) then
        iyear = iyear + 2000
      else
        iyear = iyear + 1900
      endif
      call n_time (ihour, imin, isec)

      write (xbuf, 10000) weekday(iwk_day), month(imon), idate, ihour,
     &                    imin, isec, iyear
10000 format ('# history file date ', a, 1x, a, 1x, i2, 1x, i2.2, ':',
     &   i2.2, ':', i2.2, 1x, i4)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10010) weekday(iwk_day), month(imon), idate, ihour,
     &                    imin, isec, iyear
10010 format ('# present file date ', a, 1x, a, 1x, i2, 1x, i2.2, ':',
     &   i2.2, ':', i2.2, 1x, i4)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10020) '11.1'
10020 format ('# Version ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Write title records
c
      xbuf = 'title'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      do i = 1, 2
        if (coment(i) .ne. ' ' .and. coment(i)(1:1) .ne. char(0)) then
          last = lastch (coment(i))
          status = write_ge_file (0, coment(i)(1:last))
        endif
      enddo

      xbuf = '!'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Write comments records
c
      xbuf = 'comments'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      do i = 1, ncom
        if (com(i) .ne. ' ') then
          last = lastch (com(i))
          status = write_ge_file (0, com(i)(1:last))
        endif
      enddo

      last1 = lastch(basval(1))
      last2 = lastch(basval(2))
      last3 = lastch(basval(3))

      write (xbuf, 10030) basval(2)(1:last2) // ':', basval(3)(1:last3),
     &                    basval(1)(1:last1)
10030 format ('  Source:          ', a, a, a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      last1 = lastch(basval(4))
      last2 = lastch(basval(5))
      last3 = lastch(basval(6))
      last4 = lastch(basval(7))

      write (xbuf, 10040) basval(4)(1:last1)
10040 format ('  Case:            ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10042) basval(7)(1:last4)
10042 format ('  Description:     ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10044) basval(5)(1:last2),
     &                    basval(6)(1:last3)
10044 format ('  Date:            ', a, 1x, a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      last1 = lastch(basval(9))
      last2 = lastch(basval(8))

      write (xbuf, 10050) basval(9)(1:last1)
10050 format ('  User:            ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10052) basval(8)(1:last2)
10052 format ('  PF Version:      ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      if (brdatafile .ne. ' ' .and. brdatafile(1:1) .ne. char(0)) then
        last = lastch (brdatafile)
        write (xbuf, 10054) brdatafile(1:last)
10054   format ('  Branch data:     ', a)
        last = lastch (xbuf)
        status = write_ge_file (0, xbuf(1:last))

        write (xbuf, 10056) datebr
10056   format ('  Extraction date: ', a, ' (MYYYY)')
        last = lastch (xbuf)
        status = write_ge_file (0, xbuf(1:last))

        write (xbuf, 10058) winter_code(winter_type)
10058   format ('  Winter ratings:  ', a)
        last = lastch (xbuf)
        status = write_ge_file (0, xbuf(1:last))
      endif

      iseason = ftn_atoi (option(6))
      write (xbuf, 10060) season_code(iseason)
10060 format ('  Default Ratings: ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = '!'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Write solution parameters
c
      xbuf = 'solution parameters'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'tap    1    tcul  enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'phas   1    ps    enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'area   1    area  enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'svd    0    svd   enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'dctap  1    dc    enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'ped    0    ped   enabled/disabled'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'jump  0.000250    jumper threshold'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'toler   0.2000    newton tolerance'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = 'sbase    100.0    system mva base'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      xbuf = '!'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      do i = 1, 4
        total(i) = 0
      enddo

c     Extract bus data in GE format
      numb = ext_geb ( scrfil, version, option, total)

c     Extract branch data in GE format
      numl = ext_gel ( scrfil, version, option, total, extfil,
     &                 extfilename)

c     Extract generator data in GE format
      numa = ext_geg ( scrfil, version, option, total)

c     Extract load data in GE format
      numa = ext_geld ( scrfil, version, option, total)

c     Extract shunt data in GE format
      numa = ext_geshn ( scrfil, version, option, total)

c     Extract svd data in GE format
      numa = ext_gesvd ( scrfil, version, option, total)

c     Extract area interchange data in GE format
      numa = ext_gear ( scrfil, version, option, total)

c     Extract zone interchange data in GE format
      numa = ext_gezon ( scrfil, version, option, total)
c
c     Skip interface data
c
      write (*, 10090) 0
10090 format (' * Skipping ', i4, ' interface records to NETDAT file')
      write (xbuf, 10100) 0
10100 format ('interface data  [', i4, ']                      pnet
     &qnet   -rate1- -rate2- -rate3- -rate4-')
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Skip interface branch data
c
      write (*, 10110) 0
10110 format (' * Skipping ', i4, ' interface branch records to NETDAT f
     &ile')
      write (xbuf, 10120) 0
10120 format ('interface branch data  [', i4, ']                       c
     &k      -i_no-  part_fac')
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

c     Extract d-c bus data in GE format
      num2 = ext_gedcb ( scrfil, version, option, total)

c     Extract d-c line data in GE format
      num2 = ext_gedcl ( scrfil, version, option, total)

c     Extract d-c converter data in GE format
      num2 = ext_gedcc ( scrfil, version, option, total)

c     Extract transformer impedance data in GE format
      num2 = ext_gezdt ( scrfil, version, option, total)
c
c     Skip power electronic device data
c
      write (*, 10130) 0
10130 format (' * Skipping ', i4, ' ped records to NETDAT file')
      write (xbuf, 10140) 0
10140 format ('ped data  [', i4, ']')
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

c     Extract area transaction data in GE format
      num2 = ext_getrx ( scrfil, version, option, total)

c     Extract owner data in GE format
      num2 = ext_geown ( scrfil, version, option, total)
c
c     Skip motor data
c
      write (*, 10170) 0
10170 format (' * Skipping ', i4, ' motor data records to NETDAT file')
      write (xbuf, 10180) 0
10180 format ('motor data  [', i5, ']')
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Skip line data
c
      write (*, 10190) 0
10190 format (' * Skipping ', i4, ' line data records to NETDAT file')
      write (xbuf, 10200) 0
10200 format ('line  data  [', i5, ']                                 ck
     &  se  long_id_    st resist   react   charge   rate1  rate2  rate3
     &  rate4 aloss  lngth')
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))
c
c     Write "end"
c
      xbuf = 'end'
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      call get_user (userid)
      write (xbuf, 10210) userid
10210 format ('#  This data file written by: ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

      write (xbuf, 10220) prgvsn
10220 format ('#  Using PF Version:          ', a)
      last = lastch (xbuf)
      status = write_ge_file (0, xbuf(1:last))

  900 continue
      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
      SUBROUTINE FBSV (*,ZS,ZD)
C
C     GIVEN A LOWER UNIT TRIANGULAR FACTOR WITH DIAGONAL SUPERIMPOSED
C     AND WRITTEN WITH TRAILING STRING DEFINITION WORDS, FBSV WILL
C     PERFORM THE FORWARD-BACKWARD SUBSTITUTION NECESSARY TO SOLVE A
C     LINEAR SYSTEM OF EQUATIONS.
C
C     THIS FBSV.MDS ROUTINE IS ALMOST SAME AS FBS.MIS
C     IT IS INTENDED TO BE USED FOR VAX, A VIRTUAL MEMORY MACHINE.
C     FBSV.MDS DIFFERS FROM FBS.MIS IN
C       1. THREE BUFFERS ARE USED
C       2. OPEN CORE IS REDUCED. THE INTENTION HERE IS TO AVOID
C          ACCESSIVE SYSTEM PAGING.
C
C     FBSV IS CALLED ONLY BY FBS ROUTINE.
C     IT IS INTRODUCED INTO NASTRAN REPERTORY BY G.CHAN/UNISYS, 10/88
C
      LOGICAL IDENT
      INTEGER DBL     ,DBU      ,DBB      ,DBX      ,PREC     ,SIGN    ,
     1        SYSBUF  ,PRC      ,WORDS    ,RLCMPX   ,BUF1     ,BUF2    ,
     2        BUF3    ,TYPEL    ,TYPEB    ,TYPEX    ,SUBNAM(2),BEGN    ,
     3        END     ,BUF(2)   ,RC       ,EOL      ,RD       ,RDREW   ,
     4        WRT     ,WRTREW   ,REW      ,EOFNRW   ,SWITCH   ,RSP     ,
     5        RDP     ,CSP      ,CDP      ,BLOCK(15),HICORE   ,SYS34
      REAL    ZS(1)   ,XS(4)    ,YS(4)
      DOUBLE  PRECISION          ZD(1)    ,XD       ,YD
      COMMON /FBSX  / DBL(7)    ,DBU(7)   ,DBB(7)   ,DBX(7)   ,LCORE   ,
     1                PREC      ,SIGN
      COMMON /SYSTEM/ SYSBUF    ,NOUT     ,SY1(28)  ,HICORE   ,SY2(2)  ,
     1                SYS34
      COMMON /NAMES / RD        ,RDREW    ,WRT      ,WRTREW   ,REW     ,
     1                NOREW     ,EOFNRW   ,RSP      ,RDP      ,CSP     ,
     2                CDP
      COMMON /TYPE  / PRC(2)    ,WORDS(4) ,RLCMPX(4)
      COMMON /PACKX / ITYPE1    ,ITYPE2   ,I1       ,J1       ,INCR1
      COMMON /UNPAKX/ ITYPE3    ,I2       ,J2       ,INCR2
      COMMON /ZNTPKX/ XD(2)     ,IX       ,EOL
      COMMON /ZBLPKX/ YD(2)     ,IY
      EQUIVALENCE    (DBL(5),TYPEL) , (DBB(5),TYPEB) , (DBX(5),TYPEX)  ,
     1               (XD(1) ,XS(1)) , (DBL(2),NL   ) , (YD(1) ,YS(1))
      DATA    SUBNAM/ 4HFBSV, 1H  / , BEGN/ 4HBEGN / , END/ 3HEND /
C
C
C     CHECK OPEN CORE SITUATION. IF SYS34 (PAGECNTL) IS NOT ZERO, SET
C     OPEN CORE SIZE TO SIZE SPECIFIED BY SYS34 (MINUS OVERHEAD OF 6000
C     WORDS). TOO BIG A CORE SIZE MAY CAUSE EXCESSIVE PAGING AND SLOW
C     DOWN FBS OPERATION
C
C
      KORCHG = 0
      IF (SYS34 .EQ. 0) GO TO 50
      KORCHG = HICORE - SYS34 + 6000
      IF (KORCHG .LE. 0) GO TO 80
      LCORE  = LCORE- KORCHG
      WRITE (NOUT,40) SYS34
 40   FORMAT ('0*** SYSTEM INFORMATION MESSAGE - OPEN CORE FOR FBS IS',
     1        ' SET TO',I7,' WORDS BY PAGECNTL OF /SYSTEM/',/)
      GO TO 80
 50   IF (HICORE .GT. 130001) WRITE (NOUT,60) HICORE
 60   FORMAT ('0*** SYSTEM INFORMATION MESSAGE - PRESENT OPEN CORE =',
     1        I7, /5X,'FURTHER INCREASE OF OPEN CORE MAY ACTUALLY ',
     2        'SLOW DOWN FBS''S OPERATION.', //5X,
     3        'SUGGESTION: TO OPTIMIZE CORE USAGE AND USER''S PROBLEM,',
     4        ' AND TO MINIMIZE VAX''S PAGE FAULTS,', /5X,
     4        'CHECK WORKING_SET PAGE LIMIT ASSIGNED TO USER, AND SET ',
     6        'NASTRAN PAGECNTL WORD OF /SYSTEM/ TO MATCH, BUT NOT TO ',
     7        'EXCEED, THE CURRENT SETTING',/)
C
C     GENERAL INITIALIZATION
C
 80   BUF3   = LCORE- SYSBUF
      BUF2   = BUF3 - SYSBUF
      BUF1   = BUF2 - SYSBUF
      NNN    = BUF1 - 1
      BUF(1) = SUBNAM(1)
      BUF(2) = BEGN
      CALL CONMSG (BUF,2,0)
      NBRLOD = DBB(2)
      RC     = RLCMPX(TYPEB)
      I2     = 1
      J2     = NL
      INCR2  = 1
      I1     = 1
      J1     = NL
      INCR1  = 1
      ITYPE1 = TYPEL
      ITYPE2 = TYPEX
      ITYPE3 = SIGN*TYPEL
      NWDS   = WORDS(TYPEL)*NL
      NVECS  = NNN/NWDS
      IF (NVECS .EQ. 0) CALL MESAGE(-8,NWDS-NNN,SUBNAM)
      SWITCH = 1
      IF (TYPEL.EQ.RSP .AND. RC.EQ.2) SWITCH = 2
      IF (TYPEL.EQ.RDP .AND. RC.EQ.2) SWITCH = 3
      IF (SWITCH .NE. 1) NVECS = NVECS/2
      K1     = 1
      BLOCK(1) = DBL(1)
      DBX(2) = 0
      DBX(6) = 0
      DBX(7) = 0
      IDENT  = .FALSE.
      IF (DBB(4) .EQ. 8) IDENT = .TRUE.
      NNNDBL = NNN/2
      NTERMS = RLCMPX(TYPEL)*NL
      IF (IDENT) NBRLOD = NL
C
C     OPEN OUTPUT FILE (DBX), LOAD VECTORS FILE (DBB), AND LOWER
C     TRIANGULAR FACTOR FILE (DBL)
C
      CALL GOPEN (DBX,ZS(BUF3),WRTREW)
      CALL GOPEN (DBL,ZS(BUF1),RDREW )
      IF (.NOT.IDENT) CALL GOPEN (DBB,ZS(BUF2),RDREW)
C
C     CHECK TIMING AND ISSUE MESSAGE
C
      NPASS = (NBRLOD+NVECS-1)/NVECS
      CALL SSWTCH (11,L11)
      IF (NPASS .GE. 10) L11=1
      IF (L11 .NE. 1) GO TO 140
      CALL PAGE2 (-4)
      WRITE (NOUT,100) TYPEL,NPASS
  100 FORMAT ('0*** USER INFORMATION MESSAGE FROM FBS',I1,' - NO. OF ',
     1        'PASSES NEEDED TO COMPLETE FBS OPERATION =',I5)
      IF (NPASS .GT. 15) WRITE (NOUT,110)
  110 FORMAT (5X,'INCREASE OF OPEN CORE MAY ACTUALLY SLOW DOWN FBS ',
     1        'OPERATION.')
      GO TO 140
  120 IF (L11 .LT. 0) GO TO 150
      CALL CPUTIM (J,T2,1)
      T2 = T2-T1
      IF (L11 .GT. 0) WRITE (NOUT,130) T2
  130 FORMAT (5X,'TIME TO COMPLETE ONE PASS =',F10.4,' CPU SECONDS',//)
      L11 = -1
      CALL TMTOGO (J)
      I = NPASS*T2
      IF (J .LT. I) CALL MESAGE (-50,I,SUBNAM)
      GO TO 150
  140 CALL CPUTIM (J,T1,1)
C
C     COMPUTE EXTENT OF THIS PASS
C
  150 KN   = MIN0(K1+NVECS-1,NBRLOD)
      LAST = 1 + (KN-K1)*NWDS
      IF (IDENT) GO TO 190
      GO TO (160,170,180), SWITCH
C
C     NORMAL CASE - FILL CORE WITH LOAD VECTORS
C
  160 DO 168 L=1,LAST,NWDS
      CALL UNPACK (*162,DBB,ZS(L))
      GO TO 168
  162 LN = L+NWDS-1
      DO 164 LL=L,LN
  164 ZS(LL) = 0.
  168 CONTINUE
      GO TO 200
C
C     SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP
C
  170 LAST = 1 + 2*(KN-K1)*NWDS + NWDS
      L = 0
      DO 171 K=1,NNNDBL
  171 ZD(K) = 0.
      DO 178 K=K1,KN
      ICSPSG = CSP*SIGN
      CALL INTPK (*176,DBB,0,ICSPSG,0)
  172 CALL ZNTPKI
      ZS(L+IX   ) = XS(1)
      ZS(L+IX+NL) = XS(2)
      IF (EOL .EQ. 0) GO TO 172
  176 L = L + 2*NL
  178 CONTINUE
      GO TO 200
C
C     SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP
C
  180 LAST = 1 + 2*(KN-K1)*NWDS + NWDS
      L = 0
      DO 181 K=1,NNNDBL
  181 ZD(K) = 0.
      DO 188 K=K1,KN
      ICDPSG = CDP*SIGN
      CALL INTPK (*186,DBB,0,ICDPSG,0)
  182 CALL ZNTPKI
      ZD(L+IX   ) = XD(1)
      ZD(L+IX+NL) = XD(2)
      IF (EOL .EQ. 0) GO TO 182
  186 L = L + 2*NL
  188 CONTINUE
      GO TO 200
C
C     SPECIAL CASE - GENERATE IDENTITY MATRIX
C
  190 L = 0
      DO 197 K=1,NNNDBL
  197 ZD(K) = 0.
      DO 198 K=K1,KN
      GO TO (191,192,193,194), TYPEL
  191 ZS(L+K) = 1.0
      GO TO 196
  192 ZD(L+K) = 1.0D0
      GO TO 196
  193 ZS(L+2*K-1) = 1.0
      GO TO 196
  194 ZD(L+2*K-1) = 1.0D0
  196 L = L + NTERMS
  198 CONTINUE
C
C     COMPUTE FORWARD-BACKWARD SUBSTITUTION ON LOAD VECTORS NOW IN CORE
C
  200 CALL REWIND (DBL)
      CALL FWDREC (*270,DBL)
C
      GO TO (201,202,203,204), TYPEL
C
  201 CALL FBS1 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 210
  202 CALL FBS2 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 210
  203 CALL FBS3 (BLOCK,ZS,ZS(LAST),NWDS)
      GO TO 210
  204 CALL FBS4 (BLOCK,ZS,ZS(LAST),NWDS)
C
C     PACK SOLUTION VECTORS ONTO OUTPUT FILE
C
  210 GO TO (220,230,240), SWITCH
C
C     NORMAL CASE - CALL PACK
C
  220 DO 228 L=1,LAST,NWDS
      CALL PACK (ZS(L),DBX,DBX)
  228 CONTINUE
      GO TO 250
C
C     SPECIAL CASE - FACTOR IS RSP AND VECTORS ARE CSP, CALL BLDPK
C
  230 L = 0
      DO 238 K=K1,KN
      CALL BLDPK (CSP,TYPEX,DBX,0,0)
      DO 234 I=1,NL
      YS(1) = ZS(L+I   )
      YS(2) = ZS(L+I+NL)
      IY = I
      CALL ZBLPKI
  234 CONTINUE
      CALL BLDPKN (DBX,0,DBX)
      L = L + 2*NL
  238 CONTINUE
      GO TO 250
C
C     SPECIAL CASE - FACTOR IS RDP AND VECTORS ARE CDP, CALL BLDPK
C
  240 L = 0
      DO 248 K=K1,KN
      CALL BLDPK (CDP,TYPEX,DBX,0,0)
      DO 244 I=1,NL
      YD(1) = ZD(L+I   )
      YD(2) = ZD(L+I+NL)
      IY = I
      CALL ZBLPKI
  244 CONTINUE
      CALL BLDPKN (DBX,0,DBX)
      L = L + 2*NL
  248 CONTINUE
C
C     TEST FOR MORE PASSES
C
  250 IF (KN .EQ. NBRLOD) GO TO 300
      K1   = KN + 1
      GO TO 120
C
C     ERROR
C
  270 CALL MESAGE (-2,DBL,SUBNAM)
C
  300 IF (.NOT.IDENT) CALL CLOSE (DBB,REW)
      CALL CLOSE (DBL,REW)
      CALL CLOSE (DBX,REW)
      BUF(2) = END
      CALL CONMSG (BUF,2,0)
      RETURN 1
      END


text:
program compute_areas

  use iso_fortran_env, only: compiler_version, compiler_options

  use class_Circle
  use class_Polygon
  use class_Rhombus
  use class_Square

  implicit none

  type(Circle) :: c
  type(Polygon) :: p
  type(Rhombus) :: r
  type(Square) :: s

  print '(4a)', 'This file was compiled by ', &
              compiler_version(), ' using the options ', &
              compiler_options()

  c = Circle(2.5293)
  p = Polygon(19, 1.29312)
  r = Rhombus(5.0, 7.8912)
  s = Square(10.0)

  call c%print
  call p%print
  call r%print
  call s%print

end program

max_stars_repo_name: istupsm/cmake-cookbook

max_issues_repo_name: istupsm/cmake-cookbook

max_forks_repo_name: istupsm/cmake-cookbook


text:
module Mod_rom_TurnOn
   use typre
   use Mod_PETScSystem
   use Mod_ParallelSystemInterface
   use Mod_PodRom
   use Mod_rom_Procedure
   implicit none
   private
   public SetPointersTurnOn

   !External Procedures
   procedure() :: NULLSUB

   integer(ip), allocatable :: kfl_IsSet

contains

   subroutine SetPointersTurnOn(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            select case (a%kfl_itask)

            case('FOM')
               ProcHook%TurnOn => TurnOnBuild

            case('SNP')
               ProcHook%TurnOn => TurnOnSnaps

            case('BFS')
               ProcHook%TurnOn => TurnOnBuild

            case('INT')
               ProcHook%TurnOn => TurnOnRun

            case('ROM')
               ProcHook%TurnOn => TurnOnRun
            end select

         endif

      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   subroutine TurnOnBuild

      call a%InputData
      call a%Memall
      call a%EigenSystem%SetLinearSystem(a%Problem%LinearSystem)
      call a%EigenSystem%SetOrderingPointers
      call a%EigenSystem%InitBuild(a%isnap,a%SnapshotsInterval,a%nsnap)
      if (a%kfl_massMatrix .eqv. .true.) call a%EigenSystem%SetLumpedMass(a%Mesh%vmass)
      if (a%kfl_eigentype .ne. "EPS") call a%Input
   end subroutine

   subroutine TurnOnSnaps

      call a%Memall
   end subroutine

   subroutine TurnOnRun

      call a%InputData
      call a%Memall

      a%Problem%cotol = a%cotol
      a%Problem%maxit = a%nNonLinearIterations
      call a%EigenSystem%SetLinearSystem(a%Problem%LinearSystem)
      call a%EigenSystem%SetMatrixPointers
      call a%EigenSystem%SetRHSPointers
      call a%EigenSystem%SetOrderingPointers
      call a%EigenSystem%InitSystem
      call a%InputBasis

   end subroutine

end module

subroutine rom_TurnOn(PodRom)
   use typre
   use Mod_PodRom
   use Mod_rom_Procedure
   use Mod_rom_TurnOn
   implicit none
   class(PodRomProblem),target :: PodRom
   integer(ip)    :: gnpoin,npoin,npoinLocal
   character(150) :: optfile
   character(3)   :: exmod

   a => PodRom

   call a%Problem%Timer%Total%Tic
   call a%Problem%Timer%Turnon%Tic

   !Open Files
   call a%Openfi

   !Read Data from Files
   if (a%MPIrank == a%MPIroot) then
      call a%Readat
   endif
   call a%ReadatMPI

   !Warning and errors
   call a%outerr

   !Init eigensystem
   call a%EigenSystemMemall

   call a%Mesh%GetGnpoin(gnpoin)
   call a%Mesh%GetNpoin(npoin)
   call a%Mesh%GetNpoinLocal(npoinLocal)

   exmod = a%exmod
   optfile = adjustl(trim(a%InputFolder))//'/'//adjustl(trim(a%namda))//'.'//adjustl(trim(exmod))//'.rom.sol'

   call a%SetEigenSystem
   call a%EigenSystem%SetMPI(a%MPIcomm,a%MPIsize,a%MPIroot,a%MPIrank)
   call a%EigenSystem%SetFlush(a%kfl_flush)
   call a%EigenSystem%Init(gnpoin,npoin,npoinLocal,a%ndofn,optfile,a%exmod,a%lun_solro,a%Memor)
   call a%EigenSystem%SetLinearSystem(a%Problem%LinearSystem)
   call a%EigenSystem%SetOrderingPointers

   call a%SetPointers
   call ProcHook%TurnOn
   call a%OutputTimes('turnon')

   call a%Problem%Timer%Total%Toc
   call a%Problem%Timer%Turnon%Toc

end subroutine

subroutine rom_InputBasis(a)
   use typre
   use Mod_PodRom
   implicit none
   class(PodRomProblem) :: a

   call a%Input

   select case(a%Problem%kfl_ProjectionType)
   case(0)
      call a%ComputeLumpedMassMatrix
   case(1)
      call a%ComputeMassMatrix
   end select

end subroutine

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
program AoS
  USE IFPORT
  use iso_fortran_env, only : real32, real64
  implicit none

  type charge
     real(real32) :: x,y,z,q ! Coordinates and value of the charge
  end type charge

  type(charge), allocatable :: charges(:)
  real(real32), allocatable :: potential(:)
  integer, parameter :: m = 2048, n_trials = 10
  integer :: i,j
  real(real32) :: Rx, Ry, Rz
  real(real64) :: end_time, start_time

  allocate(charges(m), potential(m*m))

  call srand(12345)

  do i = 1, m
     charges(i)%x = rand()
     charges(i)%y = rand()
     charges(i)%z = rand()
     charges(i)%q = rand()
  end do

  do i = 1, n_trials
     potential = 0.0
     call cpu_time(start_time)
     do j = 1, m*m
        Rx = real(mod(j,m))
        Ry = real(j/m)
        Rz = 0.0
        potential(j) = calculate_electric_potential(charges, Rx, Ry, Rz)
     end do
     call cpu_time(end_time)
     write(*,*) 'Trial ',i,' test ',potential(100), 'time ', end_time - start_time
  end do

contains

  function calculate_electric_potential(charges, Rx, Ry, Rz) result(phi)
    implicit none

    real(real32), intent(in) :: Rx, Ry, Rz
    type(charge),allocatable,intent(in) :: charges(:)
    real(real32) :: dx,dy,dz
    real(real32) :: phi
    integer :: i

    phi = 0.0

    do i = 1, size(charges)
       dx = charges(i)%x - Rx
       dy = charges(i)%y - Ry
       dz = charges(i)%z - Rz
       phi = phi - charges(i)%q / sqrt(dx**2 + dy**2 + dz**2)
    end do

  end function calculate_electric_potential

end program AoS

max_stars_repo_name: afanfa/OptimizedModernFortran

max_issues_repo_name: afanfa/OptimizedModernFortran

max_forks_repo_name: afanfa/OptimizedModernFortran


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Copyright (c) 2018, Neil N. Carlson
!!
!! Permission is hereby granted, free of charge, to any person obtaining a
!! copy of this software and associated documentation files (the "Software"),
!! to deal in the Software without restriction, including without limitation
!! the rights to use, copy, modify, merge, publish, distribute, sublicense,
!! and/or sell copies of the Software, and to permit persons to whom the
!! Software is furnished to do so, subject to the following conditions:
!!
!! The above copyright notice and this permission notice shall be included
!! in all copies or substantial portions of the Software.
!!
!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!! THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!! DEALINGS IN THE SOFTWARE.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use json
implicit none

class(json_value), allocatable :: val
type(json_object_iterator) :: iter
character(:), allocatable :: errmsg
integer :: stat

call json_from_string('{"abc":42,"pi":3.14,"x":"foo","y":true,"z":null}', val, stat, errmsg)
if (stat /= 0) stop 1

select type (val)
type is (json_object)

  iter = json_object_iterator(val)
  do while (.not.iter%at_end())
    select type (ival => iter%value())
    type is (json_integer)
      if (iter%name() /= 'abc') stop 11
      if (ival%value /= 42) stop 12
    type is (json_real)
      if (iter%name() /= 'pi') stop 21
      if (ival%value /= 3.14d0) stop 22
    type is (json_string)
      if (iter%name() /= 'x') stop 31
      if (ival%value /= 'foo') stop 32
    type is (json_boolean)
      if (iter%name() /= 'y') stop 41
      if (.not.ival%value) stop 42
    type is (json_null)
      if (iter%name() /= 'z') stop 51
    class default
      stop 3
    end select
    call iter%next
  end do

class default
  stop 2
end select

end

max_stars_repo_name: nncarlson/yajl-fort

max_issues_repo_name: nncarlson/yajl-fort

max_forks_repo_name: nncarlson/yajl-fort


text:
Anarchism is the attempt to eradicate domination. This includes not only such obvious forms as the nationstate, with its routine use of violence and the force of law, and the corporation, with its institutionalized irresponsibility, but also such internalized forms as patriarchy, racism, homophobia.

  See also Libertarian

Groups:
  Anarchist Reading Group
  Davis AntiAuthoritarian Collective (now defunct)
  Davis Art and Revolution
  Davis Peoples Free School
  Davis Radical Cheerleaders
  Deviant Recipes
  Food Not Bombs  serves meals every Sunday under the big tree in Central Park.

Music:
  http://kdvs.org/shows/?show1380&titleThe%20Anarchist%20Puppet%20Show&filterwed&backschedule The Anarchist Puppet Show  JD Murphy plays a mix of metal, hardcore and industrial music plus whatever else he feels like playing. Wed 03:00 AM 06:00 AM on KDVS 90.3 FM or www.kdvs.org

Projects:
  http://wewanteverything.wordpress.com/2009/09/24/communiquefromanabsentfuture/ Communique from an Absent Future  a manifesto from the UC Santa Cruz group Research and Destroy.
  Emma Goldman Institute for Anarchist Studies  an art project started by UC Davis Masters of Fine Arts student Users/stevelambert Steve Lambert.
  Burning Man  annual festival held at Black Rock City, Nevada, emphasizing art, ecology and community. This festival is popular not only with Davis locals, but also with Davis students—with more than 100 Davisdwellers in attendance.

Alternative Media:
  Davis IMCPossibly coming soon.  Until then, see http://sacindymedia.org Sacramento Indymedia

Bicycling:
  Critical Mass  last Friday of each month, meet at Central Park, 3rd and B Streets.
  Davis Bike Collective

Opponents:
  Students for an Orwellian Society
  Cows

Links to Nearby Anarchists:

  http://www.akpress.org/ AK Press  an Oakland based anarchist publisher.
  http://www.boundtogetherbooks.com/ Bound Together Books  an anarchist collective bookstore in San Francisco.
  http://members.cruzio.com/~cruzef/ Earth First! Santa Cruz  a nonhierarchical network of autonomous groups and individuals.
  http://www.freemindmedia.org/ Free Mind Media  a nonprofit collectively run community center in Santa Rosa.
  http://www.iww.org/en/branches/US/CA The Industrial Workers of the World  several branches in Northern California.
  http://thelonghaul.org/ The Long Haul  a South Berkeley Infoshop and Community Resource Center.
  http://www.geocities.com/anarcho209/ Modesto Anarcho  an anarchist publication based in Modesto.
  http://www.nobawc.org/ Network of Bay Area Worker Cooperatives  dedicated to building workplace democracy.
  http://occupyca.wordpress.com/ Occupy California  a blog related to the 2009 UC crisis.
  http://researchanddestroy.wordpress.com/ Research and Destroy  a UC Santa Cruz based group.
  http://sacramento.anarchistcafe.org/ Sacramento ACafe  a social experiment in urban anarchy.
  http://wewanteverything.wordpress.com/ We Want Everything.

SelfIdentified Anarchists:

See also:
 Protests
 Activism


text:
Kapwa is the Tagalog word for shared identity or brotherhood. Kapwa is for anyone interested in discovering more about faith and the person of Jesus both in a Pilipino/Pilipino American and university context. We are committed to growing Pilipino students in their ethnic identity, biblical justice, and evangelism through our ministry.

They meet every Thursday at 7:00pm in room 80 of the Social Sciences and Humanities Building.

For more information visit:
  http://beam.to/kapwa
  http://ucdavis.facebook.com/group.php?gid2200852974


text:
c
c -------------------------------------------------------------
c
      subroutine outvar(rect,mitot,mjtot,nvar,mptr,ng)
c
      use amr_module
      implicit double precision (a-h,o-z)

      dimension rect(nvar,mitot,mjtot)

c ::::::::::::::: OUTVAR ::::::::::::::::::::::::::::::::::
c
!>  dump soln for graphics
c
c  only output max - 1 rows and cols, since with cell centered
c  variables there is one extra cell outside the grid.
c
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c
      write(pltunit1,100) mptr
 100  format('*SOLN     ',i10,' is the grid - all variables')
c
      do 20 ivar = 1, nvar
         write(pltunit1,101) ((rect(ivar,i,j),i=ng+1,mitot-ng),
     .                                        j=ng+1,mjtot-ng)
 101     format(5e13.6)
 20   continue
c
      return
      end

max_stars_repo_name: navravi/amrclaw


text:
I was just interviewed by the Aggie for a Freshman issue.  They want a short list of good entries.  Other than Freshman Guide (thanks Jason), what should I send them?  Im off to a meeting and will likely poke around myself in the next hour.  They want entries that illuminate Davis and would make sense for a Freshman to learn about Davis in.

  Sports  for people looking to join teams?

20080829 13:16:22 nbsp I would say that Outdoor Activities and Bathrooms are extremely useful pages  Users/JoePomidor
  Oh, and Cheap Food!

20080829 13:35:25 nbsp GREENBELTS GREENBELTS GREENBELTS GREEBELTS! Users/StevenDaubert

20080829 13:41:36 nbsp I second Dauberts comment.    Also, restaurants and coffee shops would probably be helpful.  I know that would have helped me out a lot when I first moved to Davisback in the day. Users/CurlyGirl26

20080829 13:55:29 nbsp maybe some welcome to the wiki and importance of using your real name Users/StevenDaubert

20080829 13:56:24 nbsp you know what another good page is? Random page Users/StevenDaubert

20080829 13:56:55 nbsp and just watching recent changes, you see pages that are potentially interesting and whatnot Users/StevenDaubert

20080829 16:36:46 nbsp http://daviswiki.org/Bizarro_Davis Users/TheAmazingLarry

20080829 17:59:29 nbsp Id like to plug my cats page, (Poox).  She worked really hard on it. Users/jefftolentino

20080829 18:15:23 nbsp Ok in all seriousness, when I first moved here I was a big fan of all these pages: Biking, Carfree in Davis, Davis Bike Loop, Bike Church, Cheap Food, Getting the most out of your student fees, Study Spots, Good ideas for dates, Events Board. Users/jefftolentino

20080829 21:52:54 nbsp no toad sexing in Davis, Users/BarnabasTruman Users/BarnabasTruman Users/BrentLaabs


text:
module m_ExpSave

  contains

  pure real function exp_save( x )
    ! replace exp by a function that does not under/overflow dw09
    implicit none
    real, intent(in)      :: x
    real, parameter       :: maxexp = log( 2.0 ) * maxexponent( 2.0 )
    real, parameter       :: minexp = log( 2.0 ) * minexponent( 2.0 )

    if ( abs( x ) > minexp .and. abs( x ) < maxexp ) then
      exp_save = exp( x )
    else
      if ( x > 0 ) then
        if ( x > minexp ) then
          exp_save = exp( maxexp )
        else
          exp_save = exp( minexp )
        endif
      else
        if ( - x > minexp ) then
          exp_save = exp( - maxexp )
        else
          exp_save = exp( - minexp )
        endif
      endif
    endif

  end function exp_save

end module m_ExpSave

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
      REAL             FUNCTION SDOT(N,X,INCX,Y,INCY)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2006-06-07 SDOT   Krogh  Removed arithmetic if
C>> 1994-11-11 SDOT   Krogh  Declared all vars.
c>> 1994-10-20 SDOT   Krogh  Changes to use M77CON
c>> 1994-04-19 SDOT   Krogh  Minor -- Made code versions line up.
C>> 1985-08-02 SDOT   Lawson Initial code.
c--S replaces "?": ?DOT
C
C     RETURNS THE DOT PRODUCT OF X AND Y.
C     SDOT = SUM FOR I = 0 TO N-1 OF  X(LX+I*INCX) * Y(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
      INTEGER N, INCX, INCY, IX, IY, I, M, MP1, NS
      REAL             X(*),Y(*)
      SDOT = 0.0E0
      IF(N.LE.0)RETURN
      IF ((INCX .NE. INCY) .OR. (INCX .LT. 0)) THEN
C         CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
        IX = 1
        IY = 1
        IF(INCX.LT.0)IX = (-N+1)*INCX + 1
        IF(INCY.LT.0)IY = (-N+1)*INCY + 1
        DO 10 I = 1,N
          SDOT = SDOT + X(IX)*Y(IY)
          IX = IX + INCX
          IY = IY + INCY
 10     CONTINUE
      ELSE IF (INCX .EQ. 1) THEN
C        CODE FOR BOTH INCREMENTS EQUAL TO 1.
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
        M = MOD(N,5)
        IF( M .EQ. 0 ) GO TO 40
        DO 30 I = 1,M
          SDOT = SDOT + X(I)*Y(I)
 30     CONTINUE
        IF( N .LT. 5 ) RETURN
 40     MP1 = M + 1
        DO 50 I = MP1,N,5
          SDOT = SDOT + X(I)*Y(I) + X(I+1)*Y(I+1) +
     $      X(I + 2)*Y(I + 2) + X(I + 3)*Y(I + 3) + X(I + 4)*Y(I + 4)
 50     CONTINUE
      ELSE
C         CODE FOR POSITIVE EQUAL INCREMENTS .NE.1.
        NS = N*INCX
        DO 70 I=1,NS,INCX
          SDOT = SDOT + X(I)*Y(I)
 70     CONTINUE
      END IF
      RETURN
      END


text:
	SUBROUTINE GGWSLS ( filtyp, dattim, num, icolor, mrktyp, ssize,
     +			     iwidth, iflags, iret )
C************************************************************************
C* GGWWSLS								*
C*									*
C* This subroutine plots the current thunderstorm, tornado and flash	*
C* flood warnings.  It also plots the current SLS thunderstorm and	*
C* tornado watches.							*
C*									*
C* GGWSLS ( FILTYP, DATTIM, NUM, ICOLOR, MRKTYP, SSIZE, IWIDTH,	*
C*           IFLAGS, IRET )						*
C*									*
C* Input parameters:							*
C*	FILTYP		CHAR*		File type 'WARN' or 'SVRL'	*
C*	DATTIM		CHAR*		Ending time for warning or watch*
C*	NUM		INTEGER		Number of markers		*
C*	ICOLOR (NUM)	INTEGER		Marker symbol colors		*
C*	MRKTYP (NUM)	INTEGER		Marker symbol types		*
C*	SSIZE  (NUM)	REAL		Marker symbol sizes		*
C*	IWIDTH (NUM)	INTEGER		Marker symbol widths		*
C*	IFLAGS (2)	INTEGER		Flags for labels		*
C*					  0 = false			*
C*					  1 = true			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* Log:									*
C* S. Jacobs/NCEP	 5/99	Copied from GG_WTCH			*
C* S. Jacobs/NCEP	 5/99	Increased file name array size to 500	*
C* A. Hardy/GSC		 6/99	Added label flag and marker type        *
C* S. Jacobs/NCEP	 6/99	Increased array sizes, NW, to 5000	*
C* S. Jacobs/NCEP	 8/99	Changed call to FL_SCND			*
C* S. Jacobs/NCEP	 8/99	Changed call to FL_TMPL			*
C* S. Jacobs/NCEP	11/99	Increased buffer from 100 to 128	*
C* S. Jacobs/NCEP	 3/00	Changed calling sequence		*
C* D. Kidwell/NCEP	 4/00	Added processing for TEST warnings      *
C* M. Li/GSC		 5/00	Added MXFLSZ and MXNMFL			*
C* J. Wu/GSC             7/00   Added checks for TI_STAN's return status*
C* F. J. Yen/NCEP	 1/01	Changed to handle SLS watches		*
C* F. J. Yen/NCEP	 1/01	Increased NC;called ER_WMSG when over NC*
C* S. Jacobs/NCEP	 3/01	Increased file template to 48 chars	*
C* F. J. Yen/NCEP	 4/01	Fixed bug to handle corrections		*
C* S. Jacobs/NCEP	 4/01	Changed flstrt check from gt to ge	*
C* S. Jacobs/NCEP	 8/01	Added check for total num warn vs. NW	*
C* S. Jacobs/NCEP	 8/01	Changed NW to 1000 and NC to 100	*
C* A. Hardy/SAIC	12/01   Added check for missing counties	*
C* R. Tian/SAIC		02/02	Added new argument num			*
C* T. Piper/SAIC	02/02	Fixed #534P1.  num was already used	*
C* A. Hardy/SAIC         2/02   Changed call FL_SCND			*
C* S. Chiswell/Unidata	 9/02	Copied from GG_WARN			*
C* James/Unidata	 2/09   Added bin mins & mstrct to CTB_DTGET CSC*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( NW = 1000, NC = 100 )
C
	PARAMETER	( JSVR = 1, JTOR = 2, JFFW = 3 )
	PARAMETER	( JTIM = 1, JLAB = 2 )
C
C*	must be sync'd with gpwarn.h
	PARAMETER	( SLSTSTM = 9, SLSTORN = 10, SLSFFW = 11 )
C*
	CHARACTER*(*)	filtyp, dattim
	INTEGER		icolor(*), mrktyp(*), iwidth(*), iflags(*)
	REAL		ssize(*)
C*
	CHARACTER	path*25, templ*48, cdttm*20, dattm2*20,
     +			buffer*128, tfile*128, wlabel*80, dattm4*20,
     +			tmstp4*20, tmstr4*20, carr(6)*20, ttype*3,
     +			tstrt*20, tstn*7
	CHARACTER*(MXFLSZ)      filnam, files (MXNMFL)
C*
	CHARACTER	wstn(NW)*7, timstr(NW)*20, timstp(NW)*20,
     +			wtype(NW)*3
	INTEGER		itest(NW), npt(NW), nfips(NC,NW)
	REAL		rlat(NC,NW), rlon(NC,NW)
	CHARACTER	cnnam(NC,NW)*32, fipnam*8, st*2, cn*2, wfo*20
C*
	CHARACTER	stime*20, flstrt*160, ctmpl*(LLMXLN)
	INTEGER		itarr(5), jtarr(5), mrktst(17:21)
	LOGICAL		done, tplflg, found
C*
	DATA		mrktst / 2, 3, 4, 6, 14 /
C-----------------------------------------------------------------------
	iret = 0
C
C*	Scan the directory for all of the warning & SLS watch data files.
C
	CALL ST_NULL ( filtyp, ctmpl, lens, ier )
	path  = ' '
        templ = ' '
        CALL CTB_DTGET ( ctmpl, path, templ, ic, is, if, ir, ii, ion,
     +			ihb, mnb, iha, mna, mstruct, idtmch, ier )

	CALL ST_RNUL ( templ, templ, lens, ier )
	CALL ST_RNUL ( path, path, lenp, ier )
C
        nexp   = MXNMFL
	iorder = 1
	CALL FL_SCND ( path, templ, iorder, nexp, files, nfile, ier )
C
C*	Check for the last file requested by the user.
C
	CALL ST_LCUC ( dattim, dattim, ier )
	itype = 1
	IF  ( ( dattim .eq. 'LAST' ) .or.
     +	      ( dattim .eq. 'ALL' ) )  THEN
	    CALL CSS_GTIM ( itype, dattm2, ier )
	    CALL FL_MNAM ( dattm2, templ, filnam, ier )
	  ELSE
	    CALL CSS_GTIM ( itype, cdttm, ier )
	    CALL TI_STAN ( dattim, cdttm, dattm2, ier )
	    IF ( ier .ne. 0 ) THEN
	    	CALL ER_WMSG ( 'TI', ier, dattim, ierr )
	    	iret = ier
	    	return
	    ENDIF
	    CALL FL_MNAM ( dattm2, templ, filnam, ier )
	END IF
C
C*	Find the earliest file to start searching. For ALL times
C*	go back 10 days, for any other entry for dattim subtract
C*	12 hours from the time given.
C
	IF  ( dattim .eq. 'ALL' )  THEN
	    minuts = 14400
	  ELSE
	    minuts = 720
	END IF
	CALL TI_CTOI ( dattm2, itarr, ier )
	CALL TI_SUBM ( itarr, minuts, jtarr, ier )
	CALL TI_ITOC ( jtarr, stime, ier )
	CALL FL_MNAM ( stime, templ, flstrt, ier )
C
C*	Get 4-digit year to compare dates.
C
	CALL TI_DTM4 ( dattm2, dattm4, ier )
C
C*	Check the total number of warnings in the files.
C
	numw = 0
	done = .false.
	ifl  = nfile
	DO WHILE  ( ( ifl .gt. 0 ) .and. ( .not. done ) )
	    IF  ( files(ifl) .ge. flstrt )  THEN
	    	tfile = path(:lenp) // '/' // files(ifl)
		CALL FL_SOPN ( tfile, lunf, ier )
		iostat = 0
		DO WHILE  ( ( iostat .eq. 0 ) .and. ( .not. done ) )
		    READ ( lunf, 2, IOSTAT = iostat ) buffer
		    IF  ( iostat .eq. 0 )  THEN
		    	IF  ( buffer(1:1) .eq. '|' )  THEN
			    numw = numw + 1
			    IF  ( numw .gt. NW )  THEN
			    	done = .true.
				CALL ER_WMSG ( 'GG', 3, ' ', ierr )
			    END IF
			END IF
		    END IF
		END DO
		CALL FL_CLOS ( lunf, ier )
	      ELSE
	        done = .true.
	    END IF
	    ifl = ifl - 1
	END DO
C
	IF  ( ifl+1 .le. nfile )  THEN
	    flstrt = files (ifl+1)
	END IF
C
C*	Decode each file until the end time is reached.
C
	nwrn = 0
	done  = .false.
	ifl = 1
	DO WHILE  ( ( ifl .le. nfile ) .and. ( .not. done ) )
	    IF  ( files(ifl) .gt. filnam )  THEN
		done = .true.
	      ELSE
		IF  ( files(ifl) .ge. flstrt )  THEN
		  tfile = path(:lenp) // '/' // files(ifl)
		  CALL FL_SOPN ( tfile, lunf, ier )
C
		  iostat = 0
		  DO WHILE  ( iostat .eq. 0 )
		    READ ( lunf, 2, IOSTAT = iostat ) buffer
2		    FORMAT ( A )
		    IF  ( iostat .eq. 0 )  THEN
			IF  ( buffer(1:1) .eq. '|' )  THEN
			    CALL ST_CLST ( buffer, '|', ' ', 6,
     +					   carr, ignore, ier )
C
			    CALL ST_NUMB ( carr(6), jflag, ier )
			    jcorr = MOD ( jflag, 2 )
			    jtest = jflag / 2
			    ttype = carr(2)
			    tstrt = carr(3)
			    tstn  = carr(5)
			    found = .false.
			    IF  ( jcorr .eq. 1 )  THEN
C
C*				Allow for start time difference of 15
C*				minutes for warnings and 60 minutes
C*				for SLS watches for matching of
C*				correction reports.
C
				IF ( INDEX ( tstn, ',' ) .eq. 0 ) THEN
				    minup = 15
				  ELSE
				    minup = 60
				END IF
				DO  ii = 1, nwrn
				    CALL TI_DIFF ( tstrt, timstr(ii),
     +					           mindif, iret)
				    IF  ((wtype(ii) .eq. ttype) .and.
     +					 (wstn(ii)  .eq. tstn ) .and.
     +					 (mindif    .ge. 0)     .and.
     +					 (mindif    .le. minup)) THEN
					found = .true.
					iw = ii
				    END IF
				END DO
			    END IF
C
			    IF  ( found )  THEN
				jw = iw
			      ELSE
				nwrn = nwrn + 1
				jw = nwrn
			    END IF
C
			    wtype(jw)  = carr(2)
			    timstr(jw) = carr(3)
			    timstp(jw) = carr(4)
			    wstn(jw)   = carr(5)
			    itest(jw)  = jtest
			END IF
C
			knt = 0
			jostat = 0
			DO WHILE  ( jostat .eq. 0 )
			    READ ( lunf, 2, IOSTAT = jostat ) buffer
			    IF  ( jostat .eq. 0 )  THEN
				IF  ( buffer(1:1) .eq. '|' )  THEN
				    CALL FL_BKSP ( lunf, ier )
				    jostat = -1
				  ELSE
				    knt = knt + 1
				    IF ( knt .le. NC ) THEN
				        READ (buffer, 1000) fipnam,
     +					      nfips(knt,jw),
     +					      cnnam(knt,jw),
     +					      st, cn, rlat(knt,jw),
     +					      rlon(knt,jw), elv,
     +					      ipr, wfo
1000				        FORMAT ( A, 1X, I6, 1X, A, 1X,
     +                                        A, 1X, A, 1X, F9.2, 1X,
     +                                        F9.2, 1X, F9.2, 1X, I2,
     +                                        1X, A )
				    END IF
				END IF
			    END IF
			END DO
		        npt(jw) = knt
		    END IF
		  END DO
C
		  CALL FL_CLOS ( lunf, ier )
C
		END IF
C
	    END IF
	    ifl = ifl + 1
	END DO
C
C*	Query current settings.
C
	CALL GQCOLR ( jcolr, ier )
	CALL GQMRKR ( jmark, jmkhw, szmark, jmkwid, ier )
	CALL GQTEXT ( jtxfn, jtxhw, siztx, jtxwid, jbrdr,
     +		      jrrotn, jjust, ier )
C
C*	Set attributes and defaults.
C
c	CALL GSTEXT ( 21, 2, 1.0, 1, 111, 1, 1, ier )
C
	DO  i = 1, num
	    IF  ( ( mrktyp(i) .lt. 17 ) .or.
     +		  ( mrktyp(i) .gt. 21 ) ) THEN
		IF ( filtyp .eq. 'WARN' ) THEN
		    mrktyp(i) = 20
		  ELSE
		    mrktyp(i) = 18
		END IF
	    END IF
C
	    IF  ( ( ssize(i) .le.  0.0 ) .or.
     +		  ( ssize(i) .gt. 10.0 ) )  ssize(i) = 1.0
C
	    IF  ( ( iwidth(i) .le.  0 ) .or.
     +		  ( iwidth(i) .gt. 10 ) )  iwidth(i) = 2
	END DO
C
C*	Plot the graphic for each valid report.
C
	DO ip = 1, nwrn
	    CALL TI_DTM4 ( timstp ( ip ), tmstp4, ier )
	    CALL TI_DTM4 ( timstr ( ip ), tmstr4, ier )
	    IF  ( ( dattim .eq. 'ALL' ) .or.
     +		  ( ( tmstp4 .gt. dattm4 ) .and.
     +		    ( tmstr4 .le. dattm4 ) ) )  THEN
C
C*		Set the color and marker based on the type of warning
C*		or SLS watch
C
		IF  ( wtype(ip) .eq. 'TOR' .or.
     +				wtype(ip) .eq. 'TN' )  THEN
		    jtype = JTOR
		    icolv = SLSTORN
		  ELSE IF  ( wtype(ip) .eq. 'SVR' .or.
     +				wtype(ip) .eq. 'TS' )  THEN
		    jtype = JSVR
		    icolv = SLSTSTM
		  ELSE IF  ( wtype(ip) .eq. 'FFW' )  THEN
		    jtype = JFFW
		    icolv = SLSFFW
		  ELSE
		    jtype = 0
		    icolv = -1
		END IF
C
		IF ( jtype .gt. 0 ) THEN
		    ic = icolor(jtype)
		    IF ( itest ( ip ) .eq. 0 ) THEN
		        mrkr = mrktyp ( jtype )
		      ELSE
		        mrkr = mrktst ( mrktyp ( jtype ) )
		    END IF
		    CALL GSMRKR ( mrkr, 0, ssize(jtype), iwidth(jtype),
     +			          ier )
		  ELSE
		    ic = 0
		END IF
C
C*		Plot each county in the warnings or SLS watches.
C
		IF  ( ic .ne. 0 )  THEN
		  CALL GSCOLR ( ic, ier )
		  IF ( npt(ip) .gt. NC ) THEN
		      npt(ip) = NC
      		      CALL ER_WMSG ( 'GG', 2, 'GGWARN', ierr )
		  END IF
                  IF ( npt (ip) .gt. 0 ) THEN
		      DO  im = 1, npt(ip)
C
C*		          Draw the marker.
C
			  CALL plot_slsc ( icolv, nfips(im,ip) )
C		          CALL GMARK ( 'M', 1, rlat(im,ip), rlon(im,ip),
C    +				       ier )
C
C*		          Plot the text.
C
		            IF ( ( iflags(JTIM) .eq. 0 ) .and.
     +			         ( iflags(JLAB) .eq. 0 ) ) THEN
			        iyoff  = -1
			        wlabel = ' '
C
		              ELSE IF  ( ( iflags(JTIM) .eq. 0 ) .and.
     +				         ( iflags(JLAB) .ne. 0 ) ) THEN
			        iyoff  = -2
			        CALL ST_LSTR ( cnnam (im,ip), lencn,
     +                                         ier )
			        wlabel = cnnam(im,ip)(:lencn)
C
		              ELSE IF ( ( iflags(JTIM) .ne. 0 ) .and.
     +				        ( iflags(JLAB) .eq. 0 ) ) THEN
			        iyoff  = -3
			        CALL ST_LSTR ( timstr (ip), lenstr, ier)
			        CALL ST_LSTR ( timstp (ip), lenstp, ier)
			        wlabel = timstr(ip) (8:11) // '-' //
     +				 timstp(ip) (8:11)
C
		              ELSE IF ( ( iflags(JTIM) .ne. 0 ) .and.
     +				        ( iflags(JLAB) .ne. 0 ) ) THEN
			        iyoff  = -3
			        CALL ST_LSTR ( cnnam (im,ip), lencn,
     +                                         ier )
			        CALL ST_LSTR ( timstr (ip), lenstr, ier)
			        CALL ST_LSTR ( timstp (ip), lenstp, ier)
			        wlabel = cnnam(im,ip) (:lencn) // CHCR
     +				     // timstr(ip) (8:11) // '-' //
     +				     timstp(ip) (8:11)
C
		            END IF
C
		            CALL GTEXT ( 'M', rlat(im,ip), rlon(im,ip),
     +				          wlabel, 0.0, 0, iyoff, ier )
		        END DO
		    END IF
		END IF
	    END IF
	END DO
C
C*	Reset the saved attributes.
C
	CALL GSCOLR ( jcolr, ier )
	CALL GSMRKR ( jmark, jmkhw, szmark, jmkwid, ier )
	CALL GSTEXT ( jtxfn, jtxhw, siztx, jtxwid, jbrdr,
     +		      jrrotn, jjust, ier )
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


      subroutine zeroini

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine zeros values for single array variables

      use hru_module, only : hru, par, snocov1, volcrmin
      use soil_module
      use time_module

      implicit none

      real :: snocov2             !none          |2nd shape parameter for snow cover equation
                                  !              |This parameter is determined by solving the
                                  !              |equation for 95% snow cover
      snocov1 = 0.
      snocov2 = 0.
      volcrmin = 0.
      return
      end subroutine zeroini


text:
module modis18

	use CKD_common

	implicit none
	private

	integer, parameter :: ni = 4

	public :: ch18, init_ch18

contains

	subroutine init_ch18(modis_channel)

		type(ckd_type), intent(inout) :: modis_channel
		integer :: all_weights

		all_weights = ni

		modis_channel%num_weights = all_weights
		allocate(modis_channel%weights(all_weights))
		allocate(modis_channel%taus(all_weights, max_layers))

	end subroutine init_ch18

      subroutine ch18(u0, p0, t0, ux, fac, modis_channel)
!
!      This routine was developed for MODIS Channel 18
!                        10625--10740 cm^{-1}
!
!-----------------------------------------------------------------
!     Channel 18   0.931-0.941 microns
!-----------------------------------------------------------------
!  INPUTS:
!     u0 --> water vapor amount [g/cm2/km]
!     p0 --> pressure in atmospheres
!     t0 --> temp in K
!     ux --> ozone [g/cm2/km]
!     dz --> layer thickness in km
!-----------------------------------------------------------------

		real, dimension(:), intent(in) :: u0, p0, t0, ux, fac
		type(ckd_type), intent(inout) :: modis_channel

		integer, parameter :: nlev = max_levels
		integer, parameter :: nlay = max_layers
		integer, parameter :: mlv = nlay

		real :: p(nlay), t(nlay),u(nlay)

		real :: tau(ni,nlay), f(ni), twin, twinx(ni)

		integer :: i,m

      do  m=1,use_layers
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
      enddo

      call ck_18(u,f,p,t,tau)

      do  m=1,use_layers
		call window18(u(m),twin,p(m),t(m),fac(m))
        twinx(1)=0.3171613*twin*1.1551456
        twinx(2)=0.3386449*twin*1.1551456
        twinx(3)=0.2570058*twin*1.1551456
        twinx(4)=0.0871880*twin*1.1551456
        do i=1,ni ! 4 k's for h2o
          modis_channel%taus(i,m)=tau(i,m) + twinx(i)
 			if (m == 1) modis_channel%weights(i) = f(i)
        end do
      enddo

      end subroutine ch18

! *********************************************************************
      subroutine ck_18(u,f,p,t,tau)
		real, dimension(:), intent(in) :: p, t, u

		real, dimension(:), intent(inout) :: f
		real, dimension(:,:), intent(inout) :: tau

		real :: k(ni)
		real :: coefk(ni,3,num_pressures)
		integer :: i, jp, jt
      f(1)=0.564712
      f(2)=0.301482
      f(3)=0.114401
      f(4)=0.019405
      k(1)=0.11427365
      do i=2,ni
        k(i)=8.0*k(i-1)
      end do
      data ( (coefk(1,jt,jp), jp = 1, 19), jt = 1, 3)/ &
     0.00178,0.00247,0.00347,0.00492,0.00705,0.01021,&
     0.01489,0.02191,0.03250,0.04846,0.07267,0.10927,&
     0.16438,0.24712,0.37051,0.55380,0.82289,1.21665,&
     1.74535,&
     9.875E-06, 1.212E-05, 1.500E-05, 1.888E-05, 2.388E-05, 3.075E-05,&
     3.963E-05, 5.213E-05, 6.950E-05, 9.300E-05, 1.253E-04, 1.663E-04,&
     2.190E-04, 2.856E-04, 3.660E-04, 4.249E-04, 4.891E-04, 5.778E-04,&
     9.047E-04,&
     9.375E-09, 3.125E-09,-6.250E-09,-1.563E-08,-3.437E-08,-6.250E-08,&
     -9.063E-08,-1.406E-07,-2.125E-07,-2.750E-07,-3.875E-07,-5.250E-07,&
     -6.187E-07,-7.469E-07,-1.150E-06,-1.772E-06,-2.659E-06,-5.100E-06,&
     -9.363E-06/
      data ( (coefk(2,jt,jp), jp = 1, 19), jt = 1, 3)/&
     0.02158,0.02263,0.02425,0.02664,0.03007,0.03505,&
     0.04213,0.05227,0.06684,0.08765,0.11777,0.16131,&
     0.22464,0.31626,0.44584,0.62431,0.86183,1.15748,&
     1.49822,&
     2.581E-04, 2.546E-04, 2.511E-04, 2.486E-04, 2.476E-04, 2.486E-04,&
     2.507E-04, 2.555E-04, 2.618E-04, 2.651E-04, 2.680E-04, 2.665E-04,&
     2.574E-04, 2.533E-04, 2.482E-04, 1.757E-04, 1.439E-04, 6.375E-06,&
     -1.844E-04,&
     1.034E-06, 1.022E-06, 9.844E-07, 9.469E-07, 9.344E-07, 9.094E-07,&
     8.812E-07, 8.562E-07, 7.750E-07, 7.406E-07, 5.625E-07, 4.875E-07,&
     3.844E-07,-6.250E-08,-4.875E-07,-3.813E-07,-2.291E-06, 5.406E-07,&
     -7.156E-07/
      data ( (coefk(3,jt,jp), jp = 1, 19), jt = 1, 3)/&
     0.25373,0.25418,0.25492,0.25616,0.25824,0.26197,&
     0.26755,0.27693,0.29190,0.31516,0.35073,0.40191,&
     0.47139,0.56354,0.67810,0.80795,0.93901,1.05671,&
     1.11901,&
     1.636E-03, 1.633E-03, 1.627E-03, 1.618E-03, 1.603E-03, 1.581E-03,&
     1.542E-03, 1.490E-03, 1.416E-03, 1.298E-03, 1.142E-03, 9.206E-04,&
     6.606E-04, 4.164E-04, 1.916E-04,-6.375E-05,-3.354E-04,-5.551E-04,&
     -6.223E-04,&
     -8.875E-07,-8.688E-07,-8.344E-07,-7.969E-07,-7.531E-07,-6.844E-07,&
     -4.719E-07,-3.344E-07,-2.250E-07,-1.251E-08,-2.781E-07,-5.656E-07,&
     2.344E-07, 3.844E-07,-1.594E-07, 3.687E-07, 9.469E-07,-5.656E-07,&
     2.238E-06/
      data ( (coefk(4,jt,jp), jp = 1, 19), jt = 1, 3)/&
     1.85208,1.85129,1.85005,1.84809,1.84499,1.84214,&
     1.83454,1.82466,1.81037,1.78619,1.75194,1.70073,&
     1.63003,1.53482,1.41271,1.26257,1.08708,0.91236,&
     0.74049,&
     -2.769E-03,-2.765E-03,-2.759E-03,-2.751E-03,-2.737E-03,-2.720E-03,&
     -2.715E-03,-2.671E-03,-2.580E-03,-2.509E-03,-2.375E-03,-2.242E-03,&
     -2.048E-03,-1.845E-03,-1.671E-03,-1.481E-03,-1.257E-03,-1.116E-03,&
     -8.097E-04,&
     3.531E-06, 3.522E-06, 3.500E-06, 3.478E-06, 3.444E-06, 3.391E-06,&
     3.953E-06, 3.838E-06, 3.034E-06, 3.616E-06, 2.494E-06, 2.859E-06,&
     2.934E-06, 2.950E-06, 2.800E-06, 3.322E-06, 3.463E-06, 4.294E-06,&
     8.687E-07/
		call apply_ckd(ni, k, u, f, p, t, tau, coefk, .true.)
      end subroutine ck_18

!c *********************************************************************
      subroutine window18 (amnt,twin,patm,temp,fac)
!c     Parameterization of CKD_2.4 continuum over 10430 to 10960 cm-1 band
!c     Fit inaccurate for amnt < 0.01 g/cm*2;
!c          however optical depths < 0.001.
!c     INPUT:
!c     amnt = h2O layer amount (g/cm**2)
!c     patm= pressure (atm)
!c     temp = temperature (k)
!c     OUTPUT:
!c     twin = parameterized CKD_2.1 optical depth over band
!c
	  real, intent(in) :: amnt, patm, temp, fac
	  real, intent(inout) :: twin

      integer, parameter :: ncoef=7

      real ::  aa(ncoef), ph2o, tau_log
!c19   data aa/-2.119,1.002,-5.192e-03,0.9057,4.698,-1.894e-03,5.871e-02/
!c18   data aa/-1.837,1.002,-4.358e-03,0.9358,4.342,-1.518e-03,3.475e-02/
      data aa/-1.837,1.002,-4.358e-03,0.9358,4.342,-1.518e-03,3.475e-02/

      ph2o = amnt*(8.314e+07*temp)/(fac*1.0e+05*18.01534*1.01325e+06)
!c
          tau_log   = aa(1)              + &
                     aa(2) * log(amnt)  +&
                     aa(3) * temp       +&
                     aa(4) * patm       +&
                     aa(5) * ph2o       +&
                     aa(6) * amnt       +&
                     aa(7) * log(ph2o)

        twin = exp ( tau_log )
!c
        end subroutine window18

end module modis18

max_stars_repo_name: GEOS-ESM/AeroApps

max_issues_repo_name: GEOS-ESM/AeroApps

max_forks_repo_name: GEOS-ESM/AeroApps


text:
Hanlees Nissan is a car dealership that has new Nissan Automobiles vehicles and a variety of preowned cars, trucks, and SUVs.  Its been relocated from the old Ford building to its own building on 5009 Chiles Road, right next to the new Hanlees Chevrolet dealership.  It has an onsite Nissan service center and parts store.

Comments about the former and current locations also can be found on the Hanlees Ford  Nissan page.

Hanlees Auto Group is headquartered in Davis and also has dealerships throughout Northern California.

20080825 16:29:16 nbsp What a nice and clean dealership...I walked over to look at it while my car was being repaired at the Chevy store.....Its nice to know there are dealers who really care... Users/PBarringer

20100224 13:24:12 nbsp The new service manager Joe is very honest and easy to work with. There has been no Ford dealership in Davis for some time now so the Ford postings here seem irrelevent. There is a shop at the old Ford location called Davis Auto Care and they do great work. Joe is honest and will always show you the part if something is needed beyond the regular servicing.   Users/geraldquinlan

20121127 16:29:20 nbsp First, before I describe my terrible experiences at Hanlees Nissan Davis, I would like to state that I will never spend another penny there and I would strongly recommend against anyone else spending any money at Hanlees Nissan in Davis.

I own a Nissan Frontier and have taken my truck for repairs to Hanlees Nissan in Davis twice over the past 4 years. My first experience, around 2009, was average. However, my second experience, a couple years later was significantly different, in a very negative way. I am not sure if there has been a change in management or what exactly, but I would forbid against going to Hanlees Nissan in Davis for any reason. Let me describe to you my experience:

The timing chain in my car broke and the service manager at Hanlees Nissan was adamant that the engine was damaged from this incident without even looking at the car. The options that the service manager presented to me were: (1) take the risk the engine was not damaged and change the timing belt for $1200. If the engine had been damaged, this would be a waste of $1200 and the engine block would still need to be replaced. Or, (2) take the safer but far more expensive approach and replace the entire engine block for $7500. With severe pressure from the service manager, I decided to replace the entire engine block in my truck for $7500. I picked up my truck and everything seemed to be working fine at this point.

Not too long after having the entire engine replaced in my car at Hanlees Nissan, my car was due to be smogged. My car failed the smog due to the engine ignition timing being off by 10 degrees. Apparently, the timing being off this far on an engine is extremely detrimental to the engine. After finding out this information, I went back to Hanlees Nissan and explained to them the problem. They claimed that they had timed the ignition when they installed the engine and that the engine ignition timing failure was not their fault. However, Hanlees Nissan had no written proof that the engine ignition was ever timed; therefore, I am fairly certain that the engine was indeed never timed and Hanlees Nissan was trying to get out of doing the morally right thing.

Instead, the service manager offered to take a look at my truck for $99, and then adjust the timing for an additional $50 to $100 on top of that. Instead, I went to a different reputable autoshop in Davis and had the work done for $47.99. Users/DanErikson

20121127 16:38:03 nbsp Also, in addition to my previous comment regarding the poor service at Hanlees Nissan in Davis, I would also like to point out that the Better Buisiness Bureau gave Hanless Nissan in Davis an F rating (on a scale from A+ to F). This clearly describes their poor commitment to their customers. Users/DanErikson

20121127 16:42:08 nbsp Here is the link to the Better Business Bureaus website that gives Hanlees Nissan in Davis an F rating:

http://www.bbb.org/northeastcalifornia/businessreviews/autodealersnewcars/hanleyschevrolettoyotaindavisca22000178  Users/DanErikson

20130128 12:02:33 nbsp A few months ago, I bought a 2011 Rogue with approximately 30,000 miles on it from these jokers. The sales experience was smooth, easy, and relatively pleasant ... but after that, things went downhill fast.

First, there was less than one gallon of gas in the car, which we didnt realize until after we signed the papers. Guess what? Service was closed  they couldnt gas it up for us. We live in Sacramento, so this wasnt enough to get over the causeway. Im glad I noticed or that would have been a biiiig problem. As it was, I paid to fill it up, thats fine.

There was one key available and Hanlees didnt have a key machine to get a new one, so they wanted me to come back to get it. I live 20 miles away but they wanted me to drive the 40 mile roundtrip for a key at some future date. Sue, the manager, claimed shed call me when it was in. I never got a call. I sent a fax, a letter, and 3 emails  all without hearing back.

A local repairman and friend takes a look at the car 2 days after I buy it and tells me its woefully out of alignment, badly needs a tuneup, and is low on oil. Wonderful. At least the brake pads were in relatively good shape, although they werent new.

A week after buying the car, I get a call from Nissan USAs customer satisfaction department asking how things went. I tell them the truth: that there was no manual included, just one key, the ipod cable  which I was told was in the glove comparment  was missing. A new one of those is $80 online!

The Nissan USA guy said these were serious issues, that Hanlees was required to give 2 keys and a manual minimum with Nissan certified vehicles. He claimed hed deal with it. I never heard back from Hanlees, although the guy from Nissan USA called me back to tell me that he had communicated with the dealership and told them they needed to take care of these issues ASAP.

Finally, I decided just to show up on my way back from the Bay Area one day to get the key and the other things they had promised to give at a later date. I get there and have to stand outside the managers office for 17 minutes  I checked my watch  while she talked on the phone ... and it was a personal call, nothing whatsoever to do with dealership business from the side of it I hard. Lots of talk about what they had for lunch, weekend plans.

1 hour and 45 minutes after walking in the door, I had the manual, the second key, and the plastic cover for the rear seat hinge  which had been missing, and which caused my 4 yr old child to get a foot stuck.

I started to drive away ... and realized that even though they had promised the ipod cable was hooked up, it was missing. Drove back. 30 minutes later I had the cable  apparently it was lost in the Indiana Jones warehouse and it took 3 staffers a half hour to find a single cable.

The incompetence and rudeness were staggering.

But thats nothing.

I took it to a body shop 2 weeks ago for a small scratch that someone made in a parking lot. Luckily the person who bumped me paid for it. While I was there, the body shop guy took a panel off and showed me lots and lots of damage from at least one previous accident  bent flanges and mounts under a rear light, frame damage, broken clips that were to hold on the bumper, and some very messy repairs. None of this had been disclosed by the dealer at the time of sale.

So make your own decision: if youre alright with this kind of treatment, feel free to buy a car from Hanlees Nissan. I should have stuck with Volkswagen  I would have paid more for a similar car, but at least Id have amazing service. At any VW dealership  especially Niello, which I bought my previous car from  all of these things would have been delivered to my house the day after the sale if they hadnt been available at the time I drove off. And theyd never NOT gas up the car.

Buyer beware! Users/JLT

20131120 23:50:29 nbsp worst experience ever!  very rude behavior. they didnt want to answer any of your question. seems like they dont want to sell any car. trashy place. cigarette smell all over the place. totally unprofessional sales persons. decided not to buy car from there.   Users/mikesmith


text:
subroutine residuo(a, b, u, r)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(in) :: u

real, dimension(:), intent(inout) :: r

integer :: n, i

n = size(b)

r = matmul(A,u) - b

print*,
print*, 'Residuo: ', sqrt(dot_product(r,r))
print*, r(:)
print*,

end subroutine

max_stars_repo_name: UxioAndrade/Analisis-Numerico-Matricial

max_issues_repo_name: UxioAndrade/Analisis-Numerico-Matricial

max_forks_repo_name: UxioAndrade/Analisis-Numerico-Matricial


text:
!-----subroutine---------------------------------------------g.guidati--
!
     subroutine SOLSEQ
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             solve matrix
!
!.......................................................................
!               declarations
!.......................................................................
      USE TINoiseGeneric
      USE TINoiseGeo
      IMPLICIT                        NONE

   ! Local variables.
INTEGER (4)                  :: i, info

REAL (DbKi)                  :: yp1, ypn
REAL (DbKi)                  :: arr(n+1)

!.......................................................................
!     solve system of equations
!.......................................................................

      call dgetrs ('N',n+2,1,Kern,n+2,ipiv,rhs,n+2,info)
      if(info.ne.0) then
        write(*,*) 'Ich glaube, es gibt da ein Problem...'
        stop
      endif

!.......................................................................
!     spline surface distribution of potential
!.......................................................................

      do i=1,n+1
        pots(i) = rhs(i)
      enddo

      do i=1,n+1
        arr(i) = rhs(i)
      enddo

      yp1 = dst(-2,2) * rhs(1) + dst(-1,2) * rhs(2) + dst( 0,2) * rhs(3) + &
            dst( 1,2) * rhs(4) + dst( 2,2) * rhs(5)
      ypn = dst(-2,-2) * rhs(n-3) + dst(-1,-2) * rhs(n-2) + dst( 0,-2) * rhs(n-1) + &
            dst( 1,-2) * rhs(n  ) + dst( 2,-2) * rhs(n+1)

      call SPL_P (swork, pots, n+1, d2pots)
!      do i=1,n+1
!        write(190,*) swork(i),pots(i),d2pots(i),d2yc1(i),d2yc2(i)
!      enddo

!.......................................................................
!               end of subroutine
!.......................................................................
      return
!***********************************************************************
      end

max_stars_repo_name: CarloSucameli/Openfast-noise

max_issues_repo_name: CarloSucameli/Openfast-noise

max_forks_repo_name: CarloSucameli/Openfast-noise


text:
Bixby Hall is located in the Segundo housing area and is one of four residential high rises on campus  the one that is closest to the dining commons. Bixby Hall was named for Fred H. Bixby, a wealthy California cattleman who granted $250,000 to the College of Agriculture in 1948 to establish a program which would enable students to acquire agricultural field experience  the department of Agricultural Practices; after the college was reorganized in the 60s, this department was merged into the Internship and Career Center.

Today, the Leadership Academic Theme Programs Academic Theme Program is located on Bixby 2. During summer 05 it was used to house parents during summer advising, as well as members of BandUh for their retreat. Unlike Malcolm, there are no magnets to hold your door open and you use your ID card to open it.

During Fall Quarter 05 there was an ant problem in many of the rooms.  The following winter a television was acquired in the fourth floor lounge, but it disappeared mysteriously a couple months later.

According to the Davis Enterprise, there was a exploding things fire in March 06, causing evacuation.


text:
C***************************************************
C test the simplest helloworld in OpenMP Fortan
C Liao, 12/7/2010
C***************************************************
      PROGRAM HELLO
      include 'omp_lib.h'

      INTEGER NTHREADS, TID
!$OMP PARALLEL PRIVATE(NTHREADS, TID)
      TID = OMP_GET_THREAD_NUM()
      PRINT *, 'Hello World by thread ', TID
c$omp end parallel
      PRINT *, 'the end'
      END

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      SUBROUTINE OPMSG (MSG)

C  OPMSG writes out a message to the operator.  No assumptions are
C  made that a workstation is open.

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      INTEGER     NXT, ITRIM, IX, IY, MLEN, LASTB

      CHARACTER   MSG*(*)

      IF (MSG .EQ. ' ') THEN
         PRINT *, ' '
         RETURN
      ENDIF

C  set IX,LASTB to start, end of substring to be printed
      IX = 1
      MLEN = ITRIM(MSG)

100   CONTINUE
      IF (MLEN-IX .LT. MAXLIN) THEN
         PRINT *, MSG(IX:MLEN)
         RETURN
      ENDIF

      DO 200 IY = IX+MAXLIN, IX, -1
         IF (MSG(IY:IY) .EQ. ' ') THEN
            LASTB = IY
            NXT = LASTB+1
            GOTO 210
         ENDIF
200   CONTINUE

      LASTB = IX+MAXLIN
      NXT = LASTB

210   CONTINUE
      PRINT *, MSG(IX:LASTB-1)
      IX = NXT
      GOTO 100

      END


subroutine read_dump(ifile,skipdump)
!
! Subroutine controls the reading in of all data
! (SPH)
!

use sphdata
implicit none

integer,intent(in) :: ifile
logical,intent(inout) :: skipdump
integer :: check,smallfile

skipdump = .false.

check =0
smallfile = 0

print*, fileformat

print*, 'Reading SPH file'

if(fileformat=='sphNG_wkmr') then

   call rdump_sphNG_wkmr(filename(ifile),check,smallfile)

else if(fileformat=='sphNG_iab') then
   call rdump_sphNG_iab(filename(ifile),check,smallfile)

endif

! Skip small dumps
if(smallfile/=0) THEN
   print*, 'Skipping small/incomplete dump'
   skipdump = .true.
ENDIF

if (check /= 0) then
   !	If file missing in series, skip it
   IF(ifile==1) THEN
      print*, 'ERROR: Program aborted at first file read in'
      print*, " If SPH read fails, check the following:"
      print*, "    - File endianness"
      print*, "    - Default real size"
      print*, " "
      print*, " For the gfortran compiler, inserting or "
      print*, " removing the following flags should correct"
      print*, " the problem:"
      print*, "    -fconvert=swap"
      print*, "       (swaps endianness during read-in)"
      print*, "    -fdefault-real-8"
      print*, "       (sets default real to double precision)"
      stop
   ELSE
      print*, 'Skipping missing dump ',filename(ifile)
      skipdump = .true.
   ENDIF
endif

end subroutine read_dump


! { dg-do run }
! { dg-options "-fwhole-file -O3" }
! Check that the TYPE_CANONICAL is being correctly set
! for the derived types, when whole file compiling.
! (based on import.f90)
!
subroutine test(x)
  type myType3
    sequence
    integer :: i
  end type myType3
  type(myType3) :: x
  if(x%i /= 7) STOP 1
  x%i = 1
end subroutine test

program foo
  type myType3
    sequence
    integer :: i
  end type myType3

  type(myType3) :: z
  z%i = 7
  call test(z)
  if(z%i /= 1) STOP 1
end program foo