text:
c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine savarp

      implicit none
      include 'comput.inc'
      include 'const.inc'
      include 'param.inc'
      include 'plot1.inc'
      include 'plot2.inc'
      include 'plot3.inc'

c ... Compute variables for printing or plotting

c ... Function declarations
      double precision del13out, del14out, fsfunc
      external  del13out, del14out, fsfunc

c ... Local variables
      integer  iel, iso, lyr, mm, nll
      double precision fsol, temp

c ... Calculate total non-living C, minimum over the year
      temp = totc
      totc = som1c(SOIL) + som1c(SRFC) +
     &       som2c(SOIL) + som2c(SRFC) +
     &       som3c +
     &       strucc(SOIL) + strucc(SRFC) +
     &       metabc(SOIL) + metabc(SRFC)
      totc = min(totc, temp)

c ... Compute soil organic matter sums for plotting
      somsc = som1c(SOIL) + som2c(SOIL) + som3c
      somtc = somsc + strucc(SOIL) + metabc(SOIL)
      woodc = wood1c + wood2c + wood3c
      frstc = rleavc + frootcj + frootcm + fbrchc + rlwodc + crootc
      fsysc = somtc + woodc + frstc + strucc(SRFC) + metabc(SRFC) +
     &        som1c(SRFC) + som2c(SRFC)
      totsysc = fsysc + aglivc + bglivcj + bglivcm + stdedc +
     &          carbostg(CRPSYS,UNLABL) + carbostg(CRPSYS,LABELD) +
     &          carbostg(FORSYS,UNLABL) + carbostg(FORSYS,LABELD)

      do 10 iel = 1, nelem
        somse(iel) = som1e(SOIL,iel) + som2e(SOIL,iel) + som3e(iel)
        somte(iel) = somse(iel) + struce(SOIL,iel) + metabe(SOIL,iel)
        woode(iel) = wood1e(iel) + wood2e(iel) + wood3e(iel)
        frste(iel) = rleave(iel) + frootej(iel) + frootem(iel) +
     &               fbrche(iel) + rlwode(iel) + croote(iel)
        fsyse(iel) = somte(iel) + woode(iel) + frste(iel) +
     &               struce(SRFC,iel) + metabe(SRFC,iel) +
     &               som1e(SRFC,iel) + som2e(SRFC,iel)
        totsyse(iel) = fsyse(iel) + aglive(iel) + bglivej(iel) +
     &                 bglivem(iel) + stdede(iel)
10    continue

c ... Compute soil organic matter sums by isotope
      do 20 iso = UNLABL, LABELD
        somsci(iso) = som1ci(SOIL,iso) + som2ci(SOIL,iso) + som3ci(iso)
        somtci(iso) = somsci(iso) + strcis(SOIL,iso) +
     &                metcis(SOIL,iso)

c ..... Add litter layer components, including surface som1 and surface
c ..... som2, to get total organic matter including residue.  vek 08-91
        tomres(iso) = somtci(iso) +
     &                strcis(SRFC,iso) + metcis(SRFC,iso) +
     &                som1ci(SRFC,iso) + som2ci(SRFC,iso)
20    continue

c ... Sum the co2 losses back into the appropriate source/sink, klk 1/05
      csrsnk(UNLABL) = csrsnk(UNLABL) +
     &                 mt1c2(UNLABL) + mt2c2(UNLABL) +
     &                 st1c2(UNLABL) + st2c2(UNLABL) +
     &                 s11c2(UNLABL) + s12c2(UNLABL) +
     &                 s21c2(UNLABL) + s22c2(UNLABL) +
     &                 s3c2(UNLABL)  + wd1c2(UNLABL) +
     &                 wd2c2(UNLABL) + wd3c2(UNLABL) +
     &                 st1uvc2(UNLABL) + stduvc2(UNLABL)

      csrsnk(LABELD) = csrsnk(LABELD) +
     &                 mt1c2(LABELD) + mt2c2(LABELD) +
     &                 st1c2(LABELD) + st2c2(LABELD) +
     &                 s11c2(LABELD) + s12c2(LABELD) +
     &                 s21c2(LABELD) + s22c2(LABELD) +
     &                 s3c2(LABELD)  + wd1c2(LABELD) +
     &                 wd2c2(LABELD) + wd3c2(LABELD) +
     &                 st1uvc2(LABELD) + stduvc2(LABELD)

c ... Sum all state variables
c ... Include som1c(SRFC) and som2c(SRFC) since it is not included in
c ... somtc.   vek 08-91
c ... Remove strm5u and strm51 from this calculation as these variables
c ... are being added to the csrsnk(UNLABL) and csrsnk(LABELD)
c ... accumulators respectively in simsom. -mdh 7/19/01
      totalc = somtc + strucc(SRFC) + metabc(SRFC) +
     &         som1c(SRFC) + som2c(SRFC) +
     &         aglivc +  stdedc + bglivcj + bglivcm +
     &         csrsnk(UNLABL) + csrsnk(LABELD) + woodc + frstc

c ... Calculate tminrl
      plabil = 0.0
      do 50 iel = 1, nelem
        tminrl(iel) = 0.0
        do 40 lyr = 1, nlayer
          if (minerl(lyr,iel).gt.0.0) then
            tminrl(iel) = tminrl(iel) + minerl(lyr,iel)
            if (iel .eq. P) then
              fsol = fsfunc(minerl(lyr,P), pslsrb, sorpmx)
              plabil = plabil + (minerl(lyr,iel) * fsol)
            endif
          endif
40      continue
50    continue

      nll = nlayer + 1
      do 60 iel = 1, nelem

c ..... Include som1e(1,iel) and som2e(1,iel) since they are not
c ..... included in somte.  vek 08-91
c ..... Remove stream(iel+5) from this calculation as stream(iel+5) is
c ..... being added to the esrsnk(iel) accumulator in simsom. -mdh 7/19/01
        totale(iel) = tminrl(iel) + somte(iel) + struce(SRFC,iel) +
     &                metabe(SRFC,iel) + som1e(SRFC,iel) +
     &                som2e(SRFC,iel) + aglive(iel) + stdede(iel) +
     &                bglivej(iel) + bglivem(iel) + esrsnk(iel) +
     &                minerl(nll,iel) + parent(iel) + secndy(iel) +
     &                woode(iel) + frste(iel) + crpstg(iel) +
     &                forstg(iel)
        if (iel .eq. P) then
          totale(iel) = totale(iel) + occlud
        endif
60    continue

c ... Above and below ground live C/N ratio
      if (aglive(N) .gt. 0.0 .and. bglivej(N) .gt. 0.0 .and.
     &    bglivem(N) .gt. 0.0) then
        aglcn = aglivc/aglive(N)
        bglcnj = bglivcj/bglivej(N)
        bglcnm = bglivcm/bglivem(N)
      else
        aglcn = -999.0
        bglcnj = -999.0
        bglcnm = -999.0
      endif

c ... Overall c/n, c/p, and c/s ratios in soil organic matter
      do 70 iel = 1, nelem
        tcerat(iel) = somtc/somte(iel)
70    continue

c ... Average annual value of agdefac and bgdefac, the decomposition
c ... factors which combine the effects of temperature and moisture
      aagdefac = 0.0
      do 80 mm = 1, MONTHS
c ..... A negative value indicates that agdefac has not yet been
c ..... calculated for month mm
        if (agdefacm(mm) .lt. 0.) then
          goto 90
        endif
        aagdefac = aagdefac + agdefacm(mm)
80    continue
      mm = 13
90    mm = mm-1
      if (mm .gt. 0) then
        aagdefac = aagdefac/dble(mm)
      endif
      abgdefac = 0.0
      do 85 mm = 1, MONTHS
c ..... A negative value indicates that bgdefac has not yet been
c ..... calculated for month mm
        if (bgdefacm(mm) .lt. 0.) then
          goto 95
        endif
        abgdefac = abgdefac + bgdefacm(mm)
85    continue
      mm = 13
95    mm = mm-1
      if (mm .gt. 0) then
        abgdefac = abgdefac/dble(mm)
      endif

c ... Litter output
      clittr(SRFC,UNLABL) = metcis(SRFC,UNLABL) + strcis(SRFC,UNLABL)
      clittr(SRFC,LABELD) = metcis(SRFC,LABELD) + strcis(SRFC,LABELD)
      clittr(SOIL,UNLABL) = metcis(SOIL,UNLABL) + strcis(SOIL,UNLABL)
      clittr(SOIL,LABELD) = metcis(SOIL,LABELD) + strcis(SOIL,LABELD)
      tlittr(SRFC,UNLABL) = metcis(SRFC,UNLABL) + strcis(SRFC,UNLABL) +
     &                      som1ci(SRFC,UNLABL) + som2ci(SRFC,UNLABL)
      tlittr(SRFC,LABELD) = metcis(SRFC,LABELD) + strcis(SRFC,LABELD) +
     &                      som1ci(SRFC,LABELD) + som2ci(SRFC,LABELD)
      tlittr(SOIL,UNLABL) = metcis(SOIL,UNLABL) + strcis(SOIL,UNLABL) +
     &                      som1ci(SOIL,UNLABL) + som2ci(SOIL,UNLABL)
      tlittr(SOIL,LABELD) = metcis(SOIL,LABELD) + strcis(SOIL,LABELD) +
     &                      som1ci(SOIL,LABELD) + som2ci(SOIL,LABELD)

      if (labtyp .eq. 2) then
c ..... Delta 13C output
        dsomsc = del13out(somsci(LABELD), somsci(UNLABL), dsomsc)
        dsomtc = del13out(somtci(LABELD), somtci(UNLABL), dsomtc)
        dsom1c(SRFC) = del13out(som1ci(SRFC,LABELD),
     &                          som1ci(SRFC,UNLABL), dsom1c(SRFC))
        dsom1c(SOIL) = del13out(som1ci(SOIL,LABELD),
     &                          som1ci(SOIL,UNLABL), dsom1c(SOIL))
        dsom2c(SRFC) = del13out(som2ci(SRFC,LABELD),
     &                          som2ci(SRFC,UNLABL), dsom2c(SRFC))
        dsom2c(SOIL) = del13out(som2ci(SOIL,LABELD),
     &                          som2ci(SOIL,UNLABL), dsom2c(SOIL))
        dsom3c = del13out(som3ci(LABELD), som3ci(UNLABL), dsom3c)
        dslit = del13out(clittr(SRFC,LABELD) + som1ci(SRFC,LABELD),
     &                   clittr(SRFC,UNLABL) + som1ci(SRFC,UNLABL),
     &                   dslit)
        dblit = del13out(clittr(SOIL,LABELD) + som1ci(SOIL,LABELD),
     &                   clittr(SOIL,UNLABL) + som1ci(SOIL,UNLABL),
     &                   dblit)
        dstruc(SRFC) = del13out(strcis(SRFC,LABELD),
     &                          strcis(SRFC,UNLABL), dstruc(SRFC))
        dstruc(SOIL) = del13out(strcis(SOIL,LABELD),
     &                          strcis(SOIL,UNLABL), dstruc(SOIL))
        dmetc(SRFC) = del13out(metcis(SRFC,LABELD),
     &                         metcis(SRFC,UNLABL), dmetc(SRFC))
        dmetc(SOIL) = del13out(metcis(SOIL,LABELD),
     &                         metcis(SOIL,UNLABL), dmetc(SOIL))
        dcarbostg(CRPSYS) = del13out(carbostg(CRPSYS,LABELD),
     &                               carbostg(CRPSYS,UNLABL),
     &                               dcarbostg(CRPSYS))
        dcarbostg(FORSYS) = del13out(carbostg(FORSYS,LABELD),
     &                               carbostg(FORSYS,UNLABL),
     &                               dcarbostg(FORSYS))
        dautoresp(CRPSYS) = del13out(arspmth(CRPSYS,LABELD),
     &                               arspmth(CRPSYS,UNLABL),
     &                               dautoresp(CRPSYS))
        dautoresp(FORSYS) = del13out(arspmth(FORSYS,LABELD),
     &                               arspmth(FORSYS,UNLABL),
     &                               dautoresp(FORSYS))
        dhetresp = del13out(respmth(LABELD), respmth(UNLABL), dhetresp)
        dsoilresp = del13out(arspmth(CRPSYS,LABELD) +
     &                       arspmth(FORSYS,LABELD) + respmth(LABELD),
     &                       arspmth(CRPSYS,UNLABL) +
     &                       arspmth(FORSYS,UNLABL) + respmth(UNLABL),
     &                       dsoilresp)
        dbglivc = del13out(bglcisj(LABELD) + bglcism(LABELD),
     &                     bglcisj(UNLABL) + bglcism(UNLABL), dbglivc)
        dbglivcj = del13out(bglcisj(LABELD), bglcisj(UNLABL), dbglivcj)
        dbglivcm = del13out(bglcism(LABELD), bglcism(UNLABL), dbglivcm)
        dfrootc = del13out(frtcisj(LABELD) + frtcism(LABELD),
     &                     frtcisj(UNLABL) + frtcism(UNLABL), dfrootc)
        dfrootcj = del13out(frtcisj(LABELD), frtcisj(UNLABL), dfrootcj)
        dfrootcm = del13out(frtcism(LABELD), frtcism(UNLABL), dfrootcm)
        deloi = del13out(tlittr(SRFC,LABELD), tlittr(SRFC,UNLABL),
     &                   deloi)
        deloe = del13out(tlittr(SOIL,LABELD) + som3ci(LABELD),
     &                   tlittr(SOIL,UNLABL) + som3ci(UNLABL),
     &                   deloe)
      endif

      if (labtyp .eq. 1) then
c ..... Delta 14C output
        dsomsc = del14out(somsci(LABELD), somsci(UNLABL), dsomsc)
        dsomtc = del14out(somtci(LABELD), somtci(UNLABL), dsomtc)
        dsom1c(SRFC) = del14out(som1ci(SRFC,LABELD),
     &                          som1ci(SRFC,UNLABL), dsom1c(SRFC))
        dsom1c(SOIL) = del14out(som1ci(SOIL,LABELD),
     &                          som1ci(SOIL,UNLABL), dsom1c(SOIL))
        dsom2c(SRFC) = del14out(som2ci(SRFC,LABELD),
     &                          som2ci(SRFC,UNLABL), dsom2c(SRFC))
        dsom2c(SOIL) = del14out(som2ci(SOIL,LABELD),
     &                          som2ci(SOIL,UNLABL), dsom2c(SOIL))
        dsom3c = del14out(som3ci(LABELD), som3ci(UNLABL), dsom3c)
        dslit = del14out(clittr(SRFC,LABELD) + som1ci(SRFC,LABELD),
     &                   clittr(SRFC,UNLABL) + som1ci(SRFC,UNLABL),
     &                   dslit)
        dblit = del14out(clittr(SOIL,LABELD) + som1ci(SOIL,LABELD),
     &                   clittr(SOIL,UNLABL) + som1ci(SOIL,UNLABL),
     &                   dblit)
        dstruc(SRFC) = del14out(strcis(SRFC,LABELD),
     &                          strcis(SRFC,UNLABL), dstruc(SRFC))
        dstruc(SOIL) = del14out(strcis(SOIL,LABELD),
     &                          strcis(SOIL,UNLABL), dstruc(SOIL))
        dmetc(SRFC) = del14out(metcis(SRFC,LABELD),
     &                         metcis(SRFC,UNLABL), dmetc(SRFC))
        dmetc(SOIL) = del14out(metcis(SOIL,LABELD),
     &                         metcis(SOIL,UNLABL), dmetc(SOIL))
        dcarbostg(CRPSYS) = del14out(carbostg(CRPSYS,LABELD),
     &                               carbostg(CRPSYS,UNLABL),
     &                               dcarbostg(CRPSYS))
        dcarbostg(FORSYS) = del14out(carbostg(FORSYS,LABELD),
     &                               carbostg(FORSYS,UNLABL),
     &                               dcarbostg(FORSYS))
        dautoresp(CRPSYS) = del14out(arspmth(CRPSYS,LABELD),
     &                               arspmth(CRPSYS,UNLABL),
     &                               dautoresp(CRPSYS))
        dautoresp(FORSYS) = del14out(arspmth(FORSYS,LABELD),
     &                               arspmth(FORSYS,UNLABL),
     &                               dautoresp(FORSYS))
        dhetresp = del14out(respmth(LABELD), respmth(UNLABL), dhetresp)
        dsoilresp = del14out(arspmth(CRPSYS,LABELD) +
     &                       arspmth(FORSYS,LABELD) + respmth(LABELD),
     &                       arspmth(CRPSYS,UNLABL) +
     &                       arspmth(FORSYS,UNLABL) + respmth(UNLABL),
     &                       dsoilresp)
        dbglivc = del14out(bglcisj(LABELD) + bglcism(LABELD),
     &                     bglcisj(UNLABL) + bglcism(UNLABL), dbglivc)
        dbglivcj = del14out(bglcisj(LABELD), bglcisj(UNLABL), dbglivcj)
        dbglivcm = del14out(bglcism(LABELD), bglcism(UNLABL), dbglivcm)
        dfrootc = del14out(frtcisj(LABELD) + frtcism(LABELD),
     &                     frtcisj(UNLABL) + frtcism(UNLABL), dfrootc)
        dfrootcj = del14out(frtcisj(LABELD), frtcisj(UNLABL), dfrootcj)
        dfrootcm = del14out(frtcism(LABELD), frtcism(UNLABL), dfrootcm)
        deloi = del14out(tlittr(SRFC,LABELD), tlittr(SRFC,UNLABL),
     &                   deloi)
        deloe = del14out(tlittr(SOIL,LABELD) + som3ci(LABELD),
     &                   tlittr(SOIL,UNLABL) + som3ci(UNLABL),
     &                   deloe)
      endif

      return
      end

      double precision function del13out(labeled, unlabeled, oldval)

      implicit none
      include 'const.inc'

c ... Argument declarations
      double precision labeled, unlabeled, oldval

      if (unlabeled .ne. 0.0) then
        del13out = ((labeled/unlabeled)/PEEDEE - 1) * 1000
      else
        del13out = oldval
      endif

      return
      end

      double precision function del14out(labeled, unlabeled, oldval)

      implicit none
      include 'const.inc'

c ... Argument declarations
      double precision labeled, unlabeled, oldval

      if (unlabeled .ne. 0) then
c        del14out = ((labeled * 1000.0) / (labeled + unlabeled) - 1) *
c     &             1000.0
        del14out = (((labeled / unlabeled) / FRAC_C14) - 1.0) * 1000.0
      else
        del14out = oldval
      endif

      return
      end


text:
C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE YCLOPNPIX(PIXTAB,ISTAT)
*
*  Module number:
*
*  Module name: YCLOPNPIX
*
*  Keyphrase:
*  ----------
*       open input data pixel location table files
*
*  Description:
*  ------------
*       This routine opens the input data pixel location file.
*
*  FORTRAN name: yclopnpix.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*       ymsput,yfname
*  SDAS:
*       uimopn, uhdgsr, uimgid
*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Jun 01  A. Alexov       Copy of yclopn.f w/some changes
*               Oct 01  A. Alexov       Added check on type double for input
*                                       column PIXPOS; CONTXT declared
*-------------------------------------------------------------------------------
* inputs:
*       PIXTAB - name of the file
*
* outputs:
*       ISTAT - error status
*
        CHARACTER*64 PIXTAB
        INTEGER ISTAT
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
      CHARACTER*80 CONTXT
c
c the PIXTAB related global/common vars
      REAL*8 PIXPOS(3000)
      REAL*4 WAVPOS(3000)
      INTEGER PIXPOS_TOTNUM
      COMMON /PIX_POS/ PIXPOS, WAVPOS, PIXPOS_TOTNUM
C
C Local variables
C
      INTEGER NN
      REAL*8  N

C
C FILE I/O ACCESS MODES
C
        INTEGER   RDONLY
        PARAMETER (RDONLY = 1)

      INTEGER   TBNROW,CTYPE
      PARAMETER (TBNROW = 21)
      INTEGER IDIN,COLIDS,NROWS
      CHARACTER*6 COLNAM
      CHARACTER*19 CNAM,CUNIT
      CHARACTER*7  CFORMAT
      INTEGER   TYDOUB
      PARAMETER (TYDOUB = 7)

      LOGICAL NULL
      DATA COLNAM/'PIXPOS'/

C---------------------------------------------------------------------------
C
C Open table
C
        CALL UTTOPN(PIXTAB,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening pix table '//PIXTAB
                GO TO 998
        ENDIF

C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading pix table '//PIXTAB
                GO TO 999
        ENDIF
        if(NROWS.GT.2048)THEN
                CONTXT='ERROR pix tab exceeds max num of rows (2048)'
                GO TO 999
        ENDIF
C
C Get column ids.
        CALL UTCFND(IDIN,COLNAM,1,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in pix table '//
     *                  PIXTAB
                GO TO 999
        ENDIF

C
C check to make sure the data type for the pixpos column is 'double'
        CALL UTCINF(IDIN,COLIDS,CNAM,CUNIT,CFORMAT,CTYPE,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR getting column info in pix table '//
     *                  PIXTAB
                GO TO 999
        ENDIF

        IF (CTYPE.NE.TYDOUB) THEN
                CONTXT='ERROR PIXPOS is not type double in table '//
     *                  PIXTAB
                GO TO 999
        ENDIF

c get the data
        DO 2214 NN = 1, NROWS
              CALL UTRGTD(IDIN,COLIDS,1,NN,N,NULL,ISTAT)
              DO 30 JJ=1
                 IF(ISTAT.NE.0)THEN
                    CONTXT='ERROR reading pix table '//PIXTAB
                    GO TO 999
                 ENDIF
30            CONTINUE

              PIXPOS(NN)=N
C option to write the table entries to STDOUT
CCC              WRITE(CONTXT, 899), PIXPOS(NN), NN
CCC899           FORMAT('  PIXPOS : ', F14.7, ', for ROW=', I4)
CCC              CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)

 2214   CONTINUE
        PIXPOS_TOTNUM=NN-1

C close the table
        CALL UTTCLO(IDIN,ISTAT)
        ISTAT=0
        GO TO 1000
C
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END

ext: f

max_stars_repo_name: iraf-community/stsdas


text:
! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_ULS_example
   USE GALAHAD_ULS_DOUBLE
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )
   INTEGER :: i, info, m, n, ne, rank
   TYPE ( SMT_TYPE ) :: MATRIX
   TYPE ( ULS_CONTROL ) :: CONTROL
   TYPE ( ULS_AINFO ) :: AINFO
   TYPE ( ULS_FINFO ) :: FINFO
   TYPE ( ULS_SINFO ) :: SINFO
   TYPE ( ULS_FACTORS ) :: FACTORS
   INTEGER, ALLOCATABLE, DIMENSION( : ) :: ROWS, COLS
   REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: B, X

!  Read matrix order and number of entries

   READ( 5, * ) m, n, ne
   MATRIX%m = m ; MATRIX%n = n ; MATRIX%ne = ne

!  Allocate arrays of appropriate sizes

   ALLOCATE( MATRIX%VAL( ne ),  MATRIX%ROW( ne ),  MATRIX%COL( ne ) )
   ALLOCATE( B( m ), X( n ), ROWS( m ), COLS( n ) )

!  Read matrix

   READ( 5, * ) ( MATRIX%ROW( i ), MATRIX%COL( i ), MATRIX%VAL( i ), i = 1, ne )

!  Initialize the structures

   CALL ULS_initialize( FACTORS, CONTROL )

!  Analyse and factorize

   CALL ULS_analyse( MATRIX, FACTORS, CONTROL, AINFO, FINFO )
   IF ( AINFO%flag < 0 ) THEN
     WRITE( 6, '( A, I0 )' )                                                   &
       ' Failure of ULS_ANALYSE with AINFO%flag = ',  AINFO%flag
     STOP
   END IF

!  Write row and column reorderings

   CALL ULS_special_rows_and_cols( FACTORS, rank, ROWS, COLS, info )
   WRITE( 6, "( A, /, ( 10I5 ) )" ) ' row orderings:', ROWS( : rank )
   WRITE( 6, "( A, /, ( 10I5 ) )" ) ' column orderings:', COLS( : rank )

!  Read right-hand side and solve system

   READ( 5, * ) B
   CALL ULS_solve( MATRIX, FACTORS, B, X, CONTROL, SINFO )
   IF ( SINFO%flag == 0 ) WRITE( 6, '( A, /,( 6ES11.3 ) )' )                    &
     ' Solution of set of equations without refinement is', X

!  Clean up

   DEALLOCATE( MATRIX%VAL, MATRIX%ROW, MATRIX%COL )
   CALL ULS_FINALIZE( FACTORS, CONTROL, INFO )

   END PROGRAM GALAHAD_ULS_example

max_forks_repo_name: dynamics-of-stellar-systems/dynamite


text:
C Output from Public domain Ratfor, version 1.0

c Smoothing Spline LeVeRaGes = SSLVRG
c ----------------------------------- leverages = H_ii = diagonal entries of Hat matrix
      subroutine sslvrg(penalt,dofoff,x,y,w,ssw, n, knot,nk,coef,
     *     sz,lev, crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3,
     *     sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,info)

C Purpose :
C       Compute smoothing spline for smoothing parameter lambda
C       and compute one of three `criteria' (OCV , GCV , "df match").
C See comments in ./sbart.c from which this is called

      integer n,nk,icrit,ld4,ldnk,info
      DOUBLE precision penalt,dofoff,x(n),y(n),w(n),ssw,
     &     knot(nk+4), coef(nk),sz(n),lev(n), crit, lambda,
     *     xwy(nk), hs0(nk),hs1(nk),hs2(nk),hs3(nk),
     *     sg0(nk),sg1(nk),sg2(nk),sg3(nk), abd(ld4,nk),
     &     p1ip(ld4,nk), p2ip(ldnk,nk)

      EXTERNAL bvalue
      double precision bvalue
C local variables
      double precision vnikx(4,1),work(16)
      integer i,ileft,j,mflag, lenkno
      double precision b0,b1,b2,b3,eps, xv,rss,df, sumw
c
      integer interv
      external interv ! in ../../../appl/interv.c

      lenkno = nk+4
      ileft = 1
      eps = 1d-11

C compute the coefficients coef() of estimated smooth

      do i=1,nk
         coef(i) = xwy(i)
         abd(4,i) = hs0(i)+lambda*sg0(i)
      end do

      do i=1,(nk-1)
         abd(3,i+1) = hs1(i)+lambda*sg1(i)
      end do

      do i=1,(nk-2)
         abd(2,i+2) = hs2(i)+lambda*sg2(i)
      end do

      do i=1,(nk-3)
         abd(1,i+3) = hs3(i)+lambda*sg3(i)
      end do

c     factorize banded matrix abd (into upper triangular):
      call dpbfa(abd,ld4,nk,3,info)
      if(info.ne.0) then
C        matrix could not be factorized -> ier := info
         return
      endif
c     solve linear system (from factorized abd):
      call dpbsl(abd,ld4,nk,3,coef)

C     Value of smooth at the data points
      do i=1,n
         xv = x(i)
         sz(i) = bvalue(knot,coef,nk,4,xv,0)
      end do

C     Compute the criterion function if requested (icrit > 0) :
      if(icrit .ge. 1) then

C --- Ordinary or Generalized CV or "df match" ---

C     Get Leverages First
         call sinerp(abd,ld4,nk,p1ip,p2ip,ldnk, 0)
         do i=1,n
            xv = x(i)
            ileft = interv(knot(1), nk+1, xv, 0,0, ileft, mflag)
            if(mflag .eq. -1) then
               ileft = 4
               xv = knot(4)+eps
            else if(mflag .eq. 1) then
               ileft = nk
               xv = knot(nk+1) - eps
            endif
            j=ileft-3
C           call bspvd(knot,4,1,xv,ileft,4,vnikx,work)
            call bsplvd(knot,lenkno,4,xv,ileft,work,vnikx,1)
            b0=vnikx(1,1)
            b1=vnikx(2,1)
            b2=vnikx(3,1)
            b3=vnikx(4,1)
            lev(i) = (
     &              p1ip(4,j)*b0**2   + 2.d0*p1ip(3,j)*b0*b1 +
     *           2.d0*p1ip(2,j)*b0*b2   + 2.d0*p1ip(1,j)*b0*b3 +
     *              p1ip(4,j+1)*b1**2 + 2.d0*p1ip(3,j+1)*b1*b2 +
     *           2.d0*p1ip(2,j+1)*b1*b3 +    p1ip(4,j+2)*b2**2 +
     &           2.d0*p1ip(3,j+2)*b2*b3 +    p1ip(4,j+3)*b3**2
     &           )*w(i)**2
         end do

C     Evaluate Criterion

         df = 0d0
         if(icrit .eq. 1) then ! Generalized CV --------------------
            rss = ssw
            sumw = 0d0
c       w(i) are sqrt( wt[i] ) weights scaled in ../R/smspline.R such
c       that sumw =  number of observations with w(i) > 0
            do i=1,n
               rss = rss + ((y(i)-sz(i))*w(i))**2
               df = df + lev(i)
               sumw = sumw + w(i)**2
            end do

            crit = (rss/sumw)/((1d0-(dofoff + penalt*df)/sumw)**2)
c            call dblepr("spar", 4, spar, 1)
c            call dblepr("crit", 4, crit, 1)

         else if(icrit .eq. 2) then ! Ordinary CV ------------------
            crit = 0d0
            do i = 1,n
               crit = crit + (((y(i)-sz(i))*w(i))/(1-lev(i)))**2
            end do
            crit = crit/n
c            call dblepr("spar", 4, spar, 1)
c            call dblepr("crit", 4, crit, 1)

         else ! df := sum( lev[i] )
            do i=1,n
               df = df + lev(i)
            end do
            if(icrit .eq. 3) then ! df matching --------------------
               crit = 3 + (dofoff-df)**2
            else ! if(icrit .eq. 4) then df - dofoff (=> zero finding)
               crit = df - dofoff
            endif
         endif
      endif
C     Criterion evaluation
      return
      end

max_stars_repo_name: lifebit-ai/exomedepth

max_issues_repo_name: lifebit-ai/exomedepth

max_forks_repo_name: lifebit-ai/exomedepth


! https://github.com/MichaelSiehl/Atomic_Subroutines--Part_3a--How_To_Process_Array_Data

program Main
  use OOOGglob_Globals
  use OOOEerro_admError
  use OOOPimsc_admImageStatus_CA
  implicit none
  !
  integer(OOOGglob_kint) :: intNumberOfRemoteImages
  integer(OOOGglob_kint), dimension (1:3) :: intA_RemoteImageNumbers ! please compile and run the
                                                                     ! program with 4 coarray images
  integer(OOOGglob_kint) :: intSetFromImageNumber
  integer(OOOGglob_kint), dimension (1:5) :: intA_TestArrayForRemoteTransfer
  integer(OOOGglob_kint) :: intCount
  integer(OOOGglob_kint) :: intA
  !*********************************
  if (this_image() == 1) then
    !
    intNumberOfRemoteImages = 3
    intA_RemoteImageNumbers = (/2,3,4/)
    intA_TestArrayForRemoteTransfer = (/1,2,3,4,5/)
    !
    ! This routine call is to synchronize and distribute the TestArray (using atomic subroutines)
    ! to the involved remote images (2,3,4) (first phase):
    call OOOPimsc_SynchronizeAndDistributeTheTestArray_CA (OOOPimscImageStatus_CA_1, &
            intNumberOfRemoteImages, intA_RemoteImageNumbers, intA_TestArrayForRemoteTransfer)
    !
    ! initiate and wait for reverse remote transfer (second phase):
    do intCount = 1, intNumberOfRemoteImages
      intSetFromImageNumber = intA_RemoteImageNumbers(intCount)
      call OOOPimsc_InitiateAndWaitForTestArrayTransfer_CA (OOOPimscImageStatus_CA_1, intSetFromImageNumber, &
                                                               intA_TestArrayForRemoteTransfer)
      write(*,*) 'second phase: reverse remote array transfer done: on image / array data', &
                                  this_image(), intA_TestArrayForRemoteTransfer
    end do
    !
  !***********************************
  else ! this_image > 1
    intSetFromImageNumber = 1
    !
    ! This routine call is to synchronize and receive the TestArray (using atomic subroutines)
    ! on the involved images (2,3,4) (first phase):
    call OOOPimsc_InitiateAndWaitForTestArrayTransfer_CA (OOOPimscImageStatus_CA_1, intSetFromImageNumber, &
                                                             intA_TestArrayForRemoteTransfer)
    write(*,*) 'first phase: remote array transfer done: on image / array data', this_image(), intA_TestArrayForRemoteTransfer
    !
    ! synchronize and distribute the reverse remote transfer (second phase):
    intNumberOfRemoteImages = 1
    intA_RemoteImageNumbers(1) = 1
    intA = this_image()
    intA_TestArrayForRemoteTransfer = (/intA,intA,intA,intA,intA/)
    call OOOPimsc_SynchronizeAndDistributeTheTestArray_CA (OOOPimscImageStatus_CA_1, &
            intNumberOfRemoteImages, intA_RemoteImageNumbers, intA_TestArrayForRemoteTransfer)
    !
  !************************************
  end if
  !
end program Main


text:
The HuntWesson Plant, a part of Hunt Foods Co., once employed many immigrants, students and residents in its Tomatoes tomato processing operation, but has been Departed Businesses shut down since October 1999. The cannery was originally built around 1963 and used to Essence of Davis scent the Davis air and contributed to hundreds of tomatoes found rolling around and tomato trucks squished near corners. Building the plant was controversial at the time.

50 years ago: 1956 Davis  Local residents voted, 1,473 to 900, in favor of locating a multimilliondollar Hunt Foods Inc. plant in Davis. The vote came in a special straw ballot called by the city council to sample public opinion in a controversy that has stirred considerable heat between the pros and the cons. Results are not legally binding on the council, but will serve as an indication of the sentiment of the community. Proponents of the location of the Hunt plant in Davis had hoped for a twothirds majority.  The Daily Democrat 11/13/2006

It was one of the last of dozens of tomato processing plants in the area to close, and was one of the few unionized industries within Yolo County  it was the only unionized manufacturing industry within the City of Davis during its operation. The facility, with its 564,000 square feet of building space was closed down without notice when owner ConAgra Inc. moved its work to an Oakdale plant  workers showed up for their checks and were told about the closure. Despite its abrupt closure, ConAgra joined with the union representing cannery workers and successfully secured a $910,000 grant to provide job training and placement for displaced workers. ConAgra put the property up for sale shortly after closing it.

In 2006, Hanlees Chevy  Toyota  Scion leases a portion of the 100acre property as an overflow lot for their new cars and during the summer of 2006 the property was also the site of UNCANNY: Art at the Cannery.

In 2009 the site was used for the Emerson Carnival.

NC Davis Development Corporation http://www.cityofdavis.org/story/?storydemolition proposed to begin demolition of the plant on or about June 10, 2006. The land may someday be home to Cannery Park, a mixeduse development including approximately 600 homes, 11 acres of office, parks and open space.

 Post Demolition Photos

It would be great to see it put back into operation either as a Tomatoes tomato processor, or some other revenue generating source of jobs. There are a variety of high end confectioneries in the Fairfield area; maybe Davis should be known for its own milk chocolate.

Unless broke into here to take band pictures and almost got arrested.  Users/TheRadish

20051006 15:52:51 nbsp I havent heard of anyone mentioning the impact of Measure X on the Hunt plant one way or the other. It would seem that if X passes that this property will never again be usable as an industrial facility. Users/JasonAller

20051024 20:06:49 nbsp I was told today that the site is under consideration as a replacement for the City Corporation Yard. Users/JasonAller

20060129 13:22:47 nbsp If anybody knows anything else on the plant or has a story of breaking in please contact me, michelle_elizabethl@yahoo.com. Im doing a news story on the plant and need all the information I can get. Thanks. Users/MichelleLeung

20060505 21:58:20 nbsp I dont know...Ive seen cars there almost every day, and Ive heard that its still open...? Users/JulieEickhof

20060506 10:34:37 nbsp They still have security there at times.  In 2004 ACME Theatre Company was allowed to use part of one of the buildings as rehersal space. Users/JaniceGutshall

20060602 10:09:07 nbsp yeah, this place is amazingly fun to explore.  back when acme rehearsed in the cannery, I went exploring.  It was awesome.  Almost as fun as exploring Angel Island.  That place has some awesome exploring grounds. Users/JulienBiewerElstob

20060824 11:13:42 nbsp I saw the demo the other day when I took a Unitrans bus across the overpass...theyve got the place more or less leveled. Users/LeightonHinkley

20061117 21:01:31 nbsp I worked for Avi from 8992 in Industrial Engineering.  I maintained and wrote several database systems there.  Good times.  I saw the flattened plant a week ago.  I guess thats what they call progress.  What a shock and a rude ending for the oldtimers there.  Terris Users/TerrisLinenbach

20061118 10:40:31 nbsp I should add that there was some discord among the old timers with the Wesson name.  The plant was Hunts as far as they many were concerned.  In my opinion they understandably distrusted the intentions of their corporate masters.  The closure of this plant is just another sad footnote in the history of American corporate behavior. Users/TerrisLinenbach

20070105 01:46:51 nbsp Its very sketch not seeing the warehouse anymore, one of my friends who grew up on my street was very taken abake when I pointed out the fact it was missing when we were on the hill. Its just weird not seeing it there, being able to look out and across. Users/StevenDaubert

20110308 12:35:41 nbsp this place is actually pretty fun 2 skate at Users/ChillMurray

20110909 10:07:58 nbsp I still remember the scent of cooked tomatoes that would fill the town every year (early August).  That smell to me meant summer was almost over, and it was almost time to go back to school.  Despite the association being a negative one as a kid, its a fond memory... I still miss that smell during warm summer nights. Users/OldDavis73

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! Copyright (c) 2017-2021, Lawrence Livermore National Security, LLC and
! other BLT Project Developers. See the top-level LICENSE file for details
!
! SPDX-License-Identifier: (BSD-3-Clause)

!------------------------------------------------------------------------------
!
! blt_fruit_smoke.f90
!
!------------------------------------------------------------------------------
module fruit_mpi_smoke
  use iso_c_binding
  use fruit
  use mpi
  use fruit_mpi
  implicit none

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

  subroutine simple_mpi_test(comm)
        integer, intent(in) :: comm
        integer :: comm_size, comm_rank
        integer :: mpi_err_stat
        integer, parameter :: first_rank = 0

        call mpi_comm_size(comm, comm_size, mpi_err_stat)
        call mpi_comm_rank(comm, comm_rank, mpi_err_stat)

        call assert_true(comm_rank .ge. first_rank, &
             "MPI comm rank is negative; something strange is happening")
        call assert_true(comm_rank .lt. comm_size, &
             "MPI comm rank is greater than or equal to comm size")
  end subroutine simple_mpi_test

!----------------------------------------------------------------------
end module fruit_mpi_smoke
!----------------------------------------------------------------------

program fortran_mpi_test
  use fruit
  use mpi
  use fruit_mpi
  use fruit_mpi_smoke
  implicit none
  logical :: ok_on_rank, ok_on_comm

  integer :: mpi_err_stat
  integer :: comm_size, comm_rank
  integer, parameter :: comm = MPI_COMM_WORLD

  call mpi_init(mpi_err_stat)
  call mpi_comm_size(comm, comm_size, mpi_err_stat)
  call mpi_comm_rank(comm, comm_rank, mpi_err_stat)

  call init_fruit
!----------
! Our tests
  call simple_mpi_test(comm)
!----------

  call fruit_summary_mpi(comm_size, comm_rank)
  call is_all_successful(ok_on_rank)
  call mpi_allreduce(ok_on_rank, ok_on_comm, 1, MPI_LOGICAL, MPI_LAND, comm, mpi_err_stat)

  call fruit_finalize_mpi(comm_size, comm_rank)
  call mpi_finalize(mpi_err_stat)

  if (.not. ok_on_comm) then
     call exit(1)
  endif
end program fortran_mpi_test

max_stars_repo_name: nkoukpaizan/blt

max_issues_repo_name: nkoukpaizan/blt

max_forks_repo_name: nkoukpaizan/blt


text:
PROGRAM prof2letkf

 !USE common_mom4 ! Use check subroutine
 USE netcdf
 USE common, ONLY: r_size, r_sngl
 USE params_obs

 IMPLICIT NONE

!SUBROUTINE read_grid(infile,v3d,v2d)
  INTEGER :: i,j,k
  INTEGER :: ncid,istat,varid,dimid

  !INTEGER,PARAMETER :: nlon=192
  !INTEGER,PARAMETER :: nlat=189
  !INTEGER,PARAMETER :: nlev=31
  INTEGER :: nlon, nlat, nlev
  REAL(r_size), ALLOCATABLE :: lon(:)
  REAL(r_size), ALLOCATABLE :: lat(:)
  REAL(r_size), ALLOCATABLE :: lev(:)
  REAL(r_size), ALLOCATABLE :: salt(:,:,:)
  REAL(r_size), ALLOCATABLE :: temp(:,:,:)
  REAL :: time, err
  REAL(r_sngl) :: wk(6)

  CHARACTER (len=*), PARAMETER :: tsfile="ocean_temp_salt.res.nc"
  !CHARACTER (len=*), PARAMETER :: uvfile="ocean_velocity.res.nc"
  !CHARACTER (len=*), PARAMETER :: sffile="ocean_sbc.res.nc"
  CHARACTER (len=*), PARAMETER :: outfile="obsin.dat"

  call check(NF90_OPEN(tsfile,NF90_NOWRITE,ncid))
  print *, 'finish open the file: ocean_temp_salt.res.nc.'
  ! Read Dimensions
  call check(NF90_INQ_DIMID(ncid,'xaxis_1',varid))
  call check(NF90_INQUIRE_DIMENSION(ncid,varid,len=nlon))
  call check(NF90_INQ_DIMID(ncid,'yaxis_1',varid))
  call check(NF90_INQUIRE_DIMENSION(ncid,varid,len=nlat))
  call check(NF90_INQ_DIMID(ncid,'zaxis_1',varid))
  call check(NF90_INQUIRE_DIMENSION(ncid,varid,len=nlev))

  ALLOCATE(lon(nlon))
  ALLOCATE(lat(nlat))
  ALLOCATE(lev(nlev))
  ALLOCATE(salt(nlon,nlat,nlev))
  ALLOCATE(temp(nlon,nlat,nlev))

  ! Read Data
  call check(NF90_INQ_VARID(ncid,'xaxis_1',varid))
  call check(NF90_GET_VAR(ncid,varid,lon))
  print *, 'finish setting up xaxis_1.'
  call check(NF90_INQ_VARID(ncid,'yaxis_1',varid))
  call check(NF90_GET_VAR(ncid,varid,lat))
  print *, 'finish setting up yaxis_1.'
  call check(NF90_INQ_VARID(ncid,'zaxis_1',varid))
  call check(NF90_GET_VAR(ncid,varid,lev))
  print *, 'finish setting up zaxis_1.'
  call check(NF90_INQ_VARID(ncid,'Time',varid))
  call check(NF90_GET_VAR(ncid,varid,time))
  print *, 'finish setting up Time.'

  call check(NF90_INQ_VARID(ncid,'salt',varid))
  call check(NF90_GET_VAR(ncid,varid,salt))
  print *, 'finish setting up salt.'
  call check(NF90_INQ_VARID(ncid,'temp',varid))
  call check(NF90_GET_VAR(ncid,varid,temp))
  print *, 'finish setting up temp.'
  call check(NF90_CLOSE(ncid))

  OPEN(91,FILE=outfile,FORM='unformatted',ACCESS='sequential')
  DO k=1,nlev
    DO j=1,nlat
      DO i=1,nlon
        call RANDOM_NUMBER(err)
        wk(1)=id_s_obs
        wk(2)=lon(i)
        wk(3)=lat(j)
        wk(4)=lev(k)
        wk(5)=salt(i,j,k)
        wk(6)=err
        WRITE(91) wk
        wk(1)=id_t_obs
        wk(5)=temp(i,j,k)
        WRITE(91) wk
        !print *, id_s_obs,lon(i),lat(j),lev(k),salt(i,j,k),err
      END DO
    END DO
  END DO

  CLOSE(91)
!  RETURN
!END SUBROUTINE read_grid
CONTAINS

SUBROUTINE check(status)
!===============================================================================
! Check the error status of the netcdf command
!===============================================================================
  USE netcdf
  IMPLICIT NONE
  integer, intent (in) :: status
  if(status /= nf90_noerr) then
    print *, trim(nf90_strerror(status))
    stop "Stopped"
  end if
END SUBROUTINE check

END PROGRAM prof2letkf

max_stars_repo_name: GEOS-ESM/Ocean-LETKF

max_issues_repo_name: GEOS-ESM/Ocean-LETKF

max_forks_repo_name: GEOS-ESM/Ocean-LETKF