text:
C======================================================================
C  MZ_IX_NUPTAK, Subroutine
C
C  Determines N uptake
C----------------------------------------------------------------------
C  Revision history
C
C                 Written
C  02/08/1993 PWW Header revision and minor changes
C  06/01/1994 WTB Modified
C  06/28/1994 JR/BDB Changed water content dependent factor
C  03/29/2001 WBD Converted to modular format
C  12/01/2001 WDB Major revision for 2002 release
C  03/12/2003 CHP Changed senescence variable to composite (SENESCE)
C                   as defined in ModuleDefs.for
!  03/02/2005 CHP/JIL Add check for negative RNH4U & RNO3U.
!  11/07/2005 CHP Replaced FAC with SOILPROP variable KG2PPM
!  01/31/2006 CHP/JIL Fixed computation of RNLOSS to match root loss
!                     calculation in MZ_GROSUB (from 5% to .5%)
!  03/30/2006 CHP Added composition of senesced matter for SOM modules
!  10/09/2007 JIL Adapted and modified for IXIM model
C----------------------------------------------------------------------
C  Called : MZ_IX_GROSUB
C
C  Calls  : None
C----------------------------------------------------------------------
      SUBROUTINE MZ_IX_NUPTAK (DYNAMIC,                              !Control
     &      CARBO,DLAYR,EAROWT,ECNP,KG2PPM,                          !Input
     &      LCNP,LFWT,LL,NH4,NLAYR,NO3,NX,PDWI,PGROEA,PGROLF,        !Input
     &      PGRORT,PGROST,PLIGRT,PLTPOP,PTF,RCNP,RLV,RTWT,SAT,SCNP,  !Input
     &      SENESCE,SHF,STMWT,STOVWT,SW,TCNP,XSTAGE,                 !Input
     &      EARN,LEAFN,RANC,ROOTN,STEMN,STOVN,TANC,TRNU,UNH4,UNO3)   !Output

      USE ModuleDefs
      IMPLICIT  NONE
      SAVE
C----------------------------------------------------------------------
C                         Define Variables
C----------------------------------------------------------------------

      REAL        ANDEM
      REAL        CARBO
      REAL        DLAYR(NL)
      REAL        DLEAFN
      REAL        DEARN
      REAL        DNG
      REAL        DROOTN
      REAL        DSTEMN
      REAL        DSTOVN
      INTEGER     DYNAMIC
      REAL        EANC
      REAL        EARN
      REAL        EAROWT
      REAL        ECNP
      REAL        ENDEM
      REAL        KG2PPM(NL)
      REAL        FACTOR
      REAL        FNH4
      REAL        FNO3
      INTEGER     I
      INTEGER     L
      INTEGER     L1
      REAL        LANC
      REAL        LCNP
      REAL        LEAFGN
      REAL        LEAFN
      REAL        LEAFNG(50)
      REAL        LEAFNS(50)
      REAL        LEAFSN
      REAL        LEAFWTGY(50)
      REAL        LFAN(50)
      REAL        LFNRT
      REAL        LFWT
      REAL        LL(NL)
      REAL        LNDEM
      REAL        NDEM
      REAL        NH4(NL)
      INTEGER     NLAYR
      REAL        NO3(NL)
      REAL        NUF
      REAL        NRF
      REAL        NX
      REAL        ONDEM
      REAL        PDWI
      REAL        PGROEA
      REAL        PGROLF
      REAL        PGRORT
      REAL        PGROST
      REAL        PLTPOP
      REAL        PTF
      REAL        RANC
      REAL        RCNP
      REAL        RFAC
      REAL        RLV(NL)
      REAL        RNDEM
      REAL        RNH4U(NL)
      REAL        RNLOSS
      REAL        RNO3U(NL)
      REAL        ROOTN
      REAL        RTWT
      REAL        SANC
      REAL        SHF(NL)
      REAL        SMDFR
      REAL        SNAV
      REAL        SNDEM
      REAL        SNH4(NL)
      REAL        SNO3(NL)
      REAL        STEMN
      REAL        STOVN
      REAL        STOVWT
      REAL        SAT(NL)
      REAL        SCNP
      REAL        STMWT
      REAL        SW(NL)
      REAL        TANC
      REAL        TCNP
      REAL        TNDEM
      REAL        TOTNA
      REAL        TRLV
      REAL        TRNLOS
      REAL        TRNU
      REAL        UNH4(NL)
      REAL        UNO3(NL)
      REAL        XMIN
      REAL        XNDEM
      REAL        XNU
      REAL        XSTAGE

      TYPE (ResidueType) SENESCE

!----------------------------------------------------------------------
!     CHP 3/30/2006
!     Proportion of lignin in roots
      REAL PLIGRT

C----------------------------------------------------------------------
C     Initialize variables
C----------------------------------------------------------------------
!----------------------------------------------------------------------
!                     DYNAMIC = RUNINIT
!----------------------------------------------------------------------

      IF(DYNAMIC.EQ.RUNINIT.OR.DYNAMIC.EQ.SEASINIT) THEN

      ANDEM    = 0.0
      DLEAFN   = 0.0
      DEARN    = 0.0
      DNG      = 0.0
      DROOTN   = 0.0
      DSTEMN   = 0.0
      DSTOVN   = 0.0
      EANC     = 0.0
      EARN     = 0.0
      ENDEM    = 0.0
      FACTOR   = 0.0
      FNH4     = 0.0
      FNO3     = 0.0
      I        = 0
      L        = 0
      L1       = 0
      LANC     = 0.0
      LEAFGN   = 0.0
      LEAFN    = 0.0
      LEAFSN   = 0.0
      LFNRT    = 0.0
      LNDEM    = 0.0
      NDEM     = 0.0
      NRF      = 0.0
      NUF      = 0.0
      ONDEM    = 0.0
      RFAC     = 0.0
      RNDEM    = 0.0
      RNLOSS   = 0.0
      ROOTN    = 0.0
      SANC     = 0.0
      SMDFR    = 0.0
      SNAV     = 0.0
      SNDEM    = 0.0
      STEMN    = 0.0
      STOVN    = 0.0
      TNDEM    = 0.0
      TOTNA    = 0.0
      TRLV     = 0.0
      TRNLOS   = 0.0
      TRNU     = 0.0
      XMIN     = 0.0
      XNDEM    = 0.0
      XNU      = 0.0

	DO I=1,50
        LEAFNG(I)   = 0.0
	  LEAFNS(I)   = 0.0
	  LEAFWTGY(I) = 0.0
	  LFAN(I)     = 0.0
      END DO
        RNH4U = 0.0
        RNO3U = 0.0
        SNH4  = 0.0
        SNO3  = 0.0
        UNH4  = 0.0
        UNO3  = 0.0

!-----------------------------------------------------------------------
!                     DYNAMIC = INTEGR
!-----------------------------------------------------------------------
      ELSEIF(DYNAMIC.EQ.INTEGR) THEN

      IF (RTWT.GT.0.0) RANC   = ROOTN / RTWT
      IF (STOVWT.GT.0.0) TANC   = STOVN / STOVWT

      IF (STMWT.GT.0.0) SANC  = STEMN / STMWT
      IF (LFWT .GT.0.0) LANC  = LEAFN / LFWT
      IF (EAROWT.GT.0.0) THEN
         EANC = EARN / EAROWT
      ELSE
         EANC = 0.0
      ENDIF

      DO L = 1, NLAYR
         RNO3U(L) = 0.0
         RNH4U(L) = 0.0
!         TRLV     = TRLV    + RLV(L)
         TRLV     = TRLV    + RLV(L) * DLAYR(L)
         !KG2PPM(L) = 10.0/(BD(L)*DLAYR(L))
         SNO3(L) = NO3(L) / KG2PPM(L)  ! Converts (mg N/kg soil) into (kg N/ha)
         SNH4(L) = NH4(L) / KG2PPM(L)  ! JIL
      END DO

C-----------------------------------------------------------------------
C     Calculate N demand (DNG=g N/PLT) for new growth (PDWI=g/plt)
C-----------------------------------------------------------------------

      IF (PDWI .EQ. 0.0) THEN
         PDWI = 1.0
      ENDIF
      DNG = PDWI*TCNP
      IF (XSTAGE .LE. 1.2) THEN
         DNG = 0.0
      ENDIF

C-----------------------------------------------------------------------
C     Calculate total N demand (NDEM) of tops (TNDEM) and roots (RNDEM),
C     all expressed in g N/plt Convert total N demand to kg N/ha (ANDEM)
C     Grain N is mobilized before in MZ_GROSUB from shoot and/or root,
C     thus, TNDEM is calculated from STOVWT(Leaf+Stem)      JIL
C-----------------------------------------------------------------------

      TNDEM  = STOVWT * (TCNP-TANC) + DNG
      RNDEM  = RTWT   * (RCNP-RANC) + PGRORT*RCNP

	SNDEM  = AMAX1(STMWT  * (SCNP-SANC) + PGROST*SCNP, 0.0)
	ENDEM  = AMAX1(EAROWT  * (ECNP-EANC) + PGROEA*ECNP, 0.0)
	LNDEM  = AMAX1(LFWT   * (LCNP-LANC) + PGROLF*LCNP, 0.0)

      ONDEM  = LNDEM + SNDEM + ENDEM     !Organ N demand
      NDEM   = TNDEM  + RNDEM

C-----------------------------------------------------------------------
C     Convert total N demand from g N/plt to kg N/ha (ANDEM)
C-----------------------------------------------------------------------

      ANDEM  = NDEM   * PLTPOP*10.0

C-----------------------------------------------------------------------
C     Calculate potential N supply in soil layers with roots (TRNU)
C     based on soil supply  JIL
C-----------------------------------------------------------------------

      DO L = 1, NLAYR
         IF (RLV(L) .NE. 0.0) THEN
            L1 = L
C
C        The following code was written by JTR to simplify the code for the
C        generic model and to make the functions more like the water uptake
C        functions.  Done on June 28, 1994.
C
C        New water content dependent factor for uptake and new uptake
C        methods that work like the soil water uptake  -- JTR 6/94
C
            SMDFR    = 1.5-6.0*((SW(L)-LL(L))/(SAT(L)-LL(L))-0.5)**2
            SMDFR    = AMAX1 (SMDFR,0.0)
            SMDFR    = AMIN1 (SMDFR,1.0)
            RFAC     = 1.0-EXP(-8.0*RLV(L))
            FNH4     = SHF(L)*0.075
            FNO3     = SHF(L)*0.075
            RNH4U(L) = RFAC*SMDFR*FNH4*(NH4(L)-0.5)*DLAYR(L)
            RNO3U(L) = RFAC*SMDFR*FNO3*NO3(L)*DLAYR(L)
            RNH4U(L) = MAX(RNH4U(L),0.0)
            RNO3U(L) = MAX(RNO3U(L),0.0)
            TRNU     = TRNU + RNO3U(L) + RNH4U(L)     !kg N/ha
         ENDIF
      END DO

C-----------------------------------------------------------------------
C     Setting a maximum N uptake based on the capacity of the system JIL
C-----------------------------------------------------------------------

	XNU = NX *(1.0-EXP(-0.8*CARBO))*PLTPOP*10.0    !kg N/ha

	IF (TRNU .GT. XNU) THEN
	  NRF = XNU/TRNU

        TRNU = 0.0
	  DO L = 1, L1
	    RNO3U(L) = RNO3U(L) * NRF
	    RNH4U(L) = RNH4U(L) * NRF
          TRNU     = TRNU + RNO3U(L) + RNH4U(L)       !kg N/ha
	  END DO
	ENDIF

C-----------------------------------------------------------------------
C     Calculate factor (NUF) to reduce N uptake to level of demand
C-----------------------------------------------------------------------

      IF (ANDEM .LE. 0.0) THEN
         TRNU  = 0.0
         NUF   = 0.0
       ELSE
         ANDEM = AMIN1 (ANDEM,TRNU)
         IF (TRNU .EQ. 0.0) RETURN
         NUF   = ANDEM/TRNU
         TRNU  = 0.0
      ENDIF

C-------------------------------------------------------------------------
C     Calculate N uptake in soil layers with roots based on demand (kg/ha)
C-------------------------------------------------------------------------

      DO L = 1, L1
         UNO3(L) = RNO3U(L)*NUF
         UNH4(L) = RNH4U(L)*NUF
         XMIN    = 0.25/KG2PPM(L)  !At least 0.25 mg N/kg soil of NO3,
	                             !         0.50 mg N/kg soil of NH4
	                             !must remain in soil layer.
							       !Original CERES-Maize values 0.1 and 2.0  JIL

         UNO3(L) = MIN (UNO3(L),SNO3(L) - XMIN)
         UNO3(L) = MAX(UNO3(L),0.0)
         XMIN    = 0.5/KG2PPM(L)
         UNH4(L) = MIN (UNH4(L),SNH4(L) - XMIN)
         UNH4(L) = MAX(UNH4(L),0.0)
         TRNU    = TRNU + UNO3(L) + UNH4(L)   !kg[N]/ha
      END DO

      IF (PLTPOP .GT. 0.0) THEN
        TRNU = TRNU/(PLTPOP*10.0)             !g[N]/plant
      ELSE
        TRNU = 0.0
      ENDIF
C-----------------------------------------------------------------------
C     Update stover and root N
C-----------------------------------------------------------------------

      IF (NDEM .GT. TRNU) THEN
          XNDEM  = TRNU
          FACTOR = XNDEM / NDEM
          NDEM   = XNDEM
          TNDEM  = TNDEM * FACTOR
          RNDEM  = RNDEM * FACTOR
      ENDIF
         DLEAFN = 0.0
         DSTEMN = 0.0
         DEARN  = 0.0

      IF (NDEM .LE. 0.0 .OR. TRNU .LE. 0.0) THEN
         DSTOVN = 0.0
         DROOTN = 0.0
       ELSE
         !
         ! Calculate root senescence losses @ 0.5%/day
         !
         TRNLOS = 0.0
         DO L = 1, L1
!CHP/JIL 2/1/06
            !RNLOSS = 0.0
            !IF (TANC .GT. TCNP) THEN
              !RNLOSS = RANC * RTWT * 0.05 * PLTPOP * RLV(L) / TRLV
               RNLOSS = RANC * RTWT * 0.005 * PLTPOP *
     &                                RLV(L)*DLAYR(L) / TRLV
          !   g[N]/m2 = g[N]/g[root]       * plants/m2
          !                  * g[root]/plant        * fraction
            !ENDIF

            !Calculate N in senesced roots (kg/ha)
            SENESCE % ResE(L,1) = RNLOSS * 10.0
!                      kg[N]/ha =  g/m2  * 10.

            !Back calculate senesced root mass from N senesced.
            IF (RANC .GT. 0.0) THEN
              SENESCE % ResWt(L) = SENESCE % ResE(L,1) / RANC
            ELSE                               !kg[dry matter]/ha
              SENESCE % ResWt(L) = SENESCE % ResE(L,1) * 10.0 / 0.40
!              kg[dry matter]/ha =       kg[N]/ha * kg[C]/kg[N]
!                                                 / kg[C]/kg[dry matter]
            ENDIF
            !Compute lignin, cellulose and carbohydrate portions
            SENESCE % ResLig(L) = SENESCE % ResWt(L) * PLIGRT

            TRNLOS  = TRNLOS + RNLOSS
            !FON(L)  = FON(L) + RNLOSS     !FON is local variable here
         END DO

         ! Adjust DSTOVN and DROOTN to compensate for N lost to FON
         IF(NDEM.GT.0.0.AND.PLTPOP.GT.0.0) THEN
!           DSTOVN = TNDEM / NDEM*TRNU-      PTF*TRNLOS/(PLTPOP*10.0)
!           DROOTN = RNDEM / NDEM*TRNU-(1.0-PTF)*TRNLOS/(PLTPOP*10.0)
!     JIL 06/25/2007
           DSTOVN = TNDEM / NDEM*TRNU-      PTF*TRNLOS/(PLTPOP)
           DROOTN = RNDEM / NDEM*TRNU-(1.0-PTF)*TRNLOS/(PLTPOP)
!          g N/pl =   fraction  *g N/pl- fraction*g N/m2/(pl/m2)
           IF (DSTOVN .GT. 0.0.AND.ONDEM .GT. 0.0) THEN
               DLEAFN = LNDEM / ONDEM*DSTOVN
               DSTEMN = SNDEM / ONDEM*DSTOVN
               DEARN  = ENDEM / ONDEM*DSTOVN
             ELSE
               DSTEMN = DSTOVN
           ENDIF
         ENDIF
      ENDIF

      STOVN = STOVN + DSTOVN                   !g N/pl
      ROOTN = ROOTN + DROOTN                   !g N/pl

      LEAFN = LEAFN + DLEAFN                   !g N/pl
      STEMN = STEMN + DSTEMN                   !g N/pl
      EARN  = EARN  + DEARN                    !g N/pl

      IF(STOVWT.GT.0.0) TANC = STOVN / STOVWT
      IF(LFWT .GT. 0.0) LANC = LEAFN / LFWT
      IF(STMWT.GT. 0.0) SANC = STEMN / STMWT
      IF(EAROWT.GT.0.0) THEN
        EANC = EARN / EAROWT
      ELSE
        EANC = 0.0
      ENDIF

      IF(RTWT.GT.0.1*RTWT.AND.RTWT.GT.0.0)
     &   RANC  = ROOTN / (RTWT-0.01*RTWT)

      ENDIF       !Endif for DYNAMIC LOOP

      RETURN
      END SUBROUTINE MZ_IX_NUPTAK

C--------------------------------------------------------------------------------------------------
C                         Define Variables
C--------------------------------------------------------------------------------------------------

! ANDEM       !Crop N demand (kg N/ha)
! ANO3        !Total extractable nitrate N in soil profile (kg N/ha)
! ANH4        !Total extractable ammonium N in soil profile (kg N/ha)
! DLAYR(L)    !Soil thickness in layer L (cm)
! DNG         !N demand of potential new growth of tops (g N/plant)
! DROOTN      !Daily change in plant root nitrogen content (g N/plant)
! DSTOVN      !Daily change in plant stover nitrogen content (g N/plant)
! FACTOR      !Ratio of root N uptake to plant N demand
! FNH4        !Unitless soil ammonium supply index
! FNO3        !Unitless soil nitrate supply index
! FON(20)     !Fresh organic nitrogen in soil layer L due to root senescence, kg N/ha
! KG2PPM(20)  !Factor that converts mg elemental N/kg soil to kg N/ha for soil layer L
! L           !Index counter
! L1          !Lowest soil layer with roots
! LL(20)      !Lower limit of plant extractable water for soil layer L, cm3/cm3
! NDEM        !Plant nitrogen demand, g N/plant
! NH4(20)     !Ammonium in soil layer L, mg elemental N/kg soil
! NLAYR       !Number of soil layer
! NO3(20)     !Nitrate in soil layer L (mg elemental N/kg soil)
! NUF         !Plant N supply to demand used to modify N uptake
! PDWI        !Potential increment in new shoot growth, g/plant
! PGRORT      !Potential increment in new root growth, g/plant
! PLTPOP      !Plant population, plants/m2
! PTF         !Ratio of above ground biomass to total biomass
! RANC        !Root actual N concentration, g N/g root
! RCNP        !Root critical nitrogen concentration, g N/g root dry weight
! RFAC        !Interim variable describing the effects of root length density on potential N uptake from a layer
! RLV(20)     !Root length density for soil layer L, cm root/cm2 soil
! RNDEM       !Plant root demand for nitrogen (g/plant)
! RNH4U(20)   !Potential ammonia uptake from layer L, kg N/ha
! RNLOSS      !Loss of N from the plant via root exudation in one layer (g N/m2)
! RNO3U(20)   !Potential nitrate uptake from layer L, kg N/ha
! ROOTN       !Root nitrogen content, g N/plant
! RTWT        !Root weight, g/plant
! SHF(20)     !Relative root distribution in soil layer L (0-1)
! SMDFR       !Soil moisture deficit factor affecting N uptake
! SNH4(20)    !Ammonium nitrogen in soil layer L, kg N/ha
! SNO3(20)    !Nitrate content in soil layer L, kg N/ha
! STOVN       !Nitrogen content in stover, g N/plant
! STOVWT      !Stover weight (Stem + leaf), g/plant
! SAT(20)     !Saturated water holding capacity for soil layer L, cm3/cm3
! SW(20)      !Soil water content in layer L, cm3 water/cm3 soil
! TANC        !Nitrogen content in above ground biomass, decimal
! TCNP        !Critical nitrogen concentration in tops, g N/g dry weight
! TNDEM       !Plant tops demand for nitrogen (g N/plant)
! TRLV        !Total root length density, cm root/cm2 soil
! TRNLOS      !Total plant N lost by root exudation (g N/m2)
! TRNU        !Total potential root nitrogen uptake, kg N/ha converted to g N/pl
! UNH4(20)    !Plant uptake of ammonium from layer (kg N/ha/day)
! UNO3(20)    !Plant uptake of nitrate from a layer (kg N/ha/day)
! XMIN        !Minimum amount of NO3, NH4 remaining in soil layer (kg N/ha)
! XNDEM       !Temporary variable
! XNU         !Maximum allowable daily N uptake (kg N/ha)
! XSTAGE      !Non-integer growth stage indicator

max_stars_repo_name: vstocca/dssat-csm-os

max_issues_repo_name: vstocca/dssat-csm-os

max_forks_repo_name: vstocca/dssat-csm-os


SUBROUTINE INVERSSYMDEF(A,AINV)
  IMPLICIT REAL*8 (A-H,O-Z)
  DIMENSION A(3,3),AINV(3,3)
  det= a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2)-a(3,1)*a(2,2)*a(1,3)-a(1,1)*a(3,2)*a(2,3)-a(2,1)*a(1,2)*a(3,3)
  AINV(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  AINV(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  AINV(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  AINV(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  AINV(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  AINV(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  AINV(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  AINV(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  AINV(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE INVERSSYMDEF


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.02.04.01/08                        *
C  *    TEST TITLE : Annotation text alignment             *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      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)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C text alignment horizontal
      INTEGER    PAHNOR,     PALEFT,     PACENT,     PARITE
      PARAMETER (PAHNOR = 0, PALEFT = 1, PACENT = 2, PARITE = 3)
C text alignment vertical
      INTEGER    PAVNOR,     PATOP,      PACAP,     PAHALF,
     1           PABASE,     PABOTT
      PARAMETER (PAVNOR = 0, PATOP  = 1, PACAP = 2, PAHALF = 3,
     1           PABASE = 4, PABOTT = 5)

C text path
      INTEGER    PRIGHT,     PLEFT,     PUP,     PDOWN
      PARAMETER (PRIGHT = 0, PLEFT = 1, PUP = 2, PDOWN = 3)

C text precision
      INTEGER    PSTRP,     PCHARP,     PSTRKP
      PARAMETER (PSTRP = 0, PCHARP = 1, PSTRKP = 2)

C linetype
      INTEGER    PLSOLI,     PLDASH,     PLDOT,     PLDASD
      PARAMETER (PLSOLI = 1, PLDASH = 2, PLDOT = 3, PLDASD = 4)

      INTEGER    PICSTR, TXCI, IX, NUMLIN, ALGNH(6),ALGNV(6),ALGNTP(6)
      INTEGER    RALGNH(6),RALGNV(6), EALGNH(6),EALGNV(6), IDUM1
      INTEGER    PERM(20), RNDINT

      REAL       NTXWD,NTXHT, CHHT, YMID, NPCX,NPCY,NPCPWC
      REAL       VTAB(PATOP:PABOTT), HTAB(PALEFT:PARITE), YTOP,YINCR
      REAL       YLO,YHI, YHALF, TXPOSX,TXPOSY, XINCR,XLEFT,XMID
      REAL       XLO,XHI, XHALF, XA(2),YA(2), Z
      PARAMETER (Z = 0.0)

      CHARACTER  TXSTR*8, DIG2*2

      CALL INITGL ('04.02.04.01/08')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C set-up of workstation and dialogue area
      PICSTR = 101
      TXCI = 1
      CALL SETDLG (PICSTR, 801,TXCI)
      CALL WCNPC (0.0, 0.0, NPCX,NPCY, NPCPWC)

      CALL POPST (PICSTR)
C  by convention, view #1 is for picture
      CALL PSVWI (1)
C  use individual attributes
      CALL SETASF (PINDIV)

C  set text font = 2, text precision = STROKE
      CALL PSTXFN (2)
      CALL PSTXPR (PSTRKP)
      CALL PEXST (102)
      CALL PCLST

C  try for 2 distinct colors
      CALL DISCOL (2, WKID, IDUM1)

      CALL POPST (102)

C  txstr = annotation text string to be used for test = "Widget!?"
      TXSTR = 'Widget!?'

C  use <inquire text extent> on horizontal txstr to determine:
C    ntxwd  = nominal width of text extent rectangle
C    ntxht  = nominal height of text extent rectangle
C    vtab,htab = normalized heights and widths
      CALL TXEXAL (2, PRIGHT, TXSTR, NTXWD, NTXHT, HTAB, VTAB)

C  table of alignments and paths to be tested:
C
C       hor-align  vert-align  annotation text path
C       algnh      algnv       algntp
C       ---------  ----------  ---------
C    1: left       top         left
C    2: center     cap         right
C    3: right      half        left
C    4: right      base        right
C    5: center     bottom      left
C    6: left       bottom      right
      CALL SETVAL ('1,2,3,3,2,1', ALGNH)
      CALL SETVAL ('1,2,3,4,5,5', ALGNV)
      CALL SETVAL ('1,0,1,0,1,0', ALGNTP)

      NUMLIN = 6
      CALL RNPERM (NUMLIN, PERM)
      YINCR = 1.0 / (NUMLIN+1)
      YTOP  = 1-YINCR
C  scale to fit
      CHHT = MIN (0.7/NTXWD, (0.8*YINCR)/NTXHT)
      CALL PSATCH (CHHT * NPCPWC)

C  draw and label 6 identical horizontal text rectangles,
C    using dotted lines, distinct color, dashed baseline
C    stacked vertically, and labelled 1-6
      CALL PSTXCI (1)
      CALL PSPLCI (2)
      CALL NUMLAB (NUMLIN, 0.15, YTOP, YINCR)
      XLO = 0.2
      XHI = XLO + CHHT*NTXWD
      YHALF = CHHT*NTXHT / 2
      XA(1) = XLO
      XA(2) = XHI
      DO 200 YMID = YTOP, YINCR/2, -YINCR
         CALL PSLN (PLDOT)
         CALL DRWREC (XLO,XHI, YMID-YHALF, YMID+YHALF)
         CALL PSLN (PLDASH)
         YA(1) = YMID - YHALF + CHHT*VTAB(PABASE)
         YA(2) = YA(1)
         CALL PPL (2,XA,YA)
200   CONTINUE

C  draw in annotation text
      DO 300 IX = 1,NUMLIN
C  set desired y-location based on perm(ix); find bottom of rectangle
         YLO  = YTOP - YHALF - (YINCR*(PERM(IX)-1))
C  calculate txpos = annotation text position, so as to fit annotation text
C    into expected box, using values from algnh(ix),algnv(ix)
         TXPOSX = XLO + CHHT * HTAB(ALGNH(IX))
         TXPOSY = YLO + CHHT * VTAB(ALGNV(IX))

C  if ix=6 then change txpos to generate incorrect result
         IF (IX .EQ. NUMLIN) THEN
            TXPOSX = TXPOSX + 0.1 * (RNDINT(0,1) - 0.5)
         ENDIF
C  set annotation text alignment = algnh(ix), algnv(ix)
         CALL PSATAL (ALGNH(IX), ALGNV(IX))
C  set annotation text path = algntp(ix)
         CALL PSATP (ALGNTP(IX))
C  draw annotation text at txpos
         CALL PATR (TXPOSX,TXPOSY, Z,Z, TXSTR)
300   CONTINUE

      CALL SETMSG ('1 2 5 9 19 23 56 57 58 63 64 65 66', 'Explicit ' //
     1             'annotation text alignment attributes should '    //
     2             'affect the position of a horizontal annotation ' //
     3             'text rectangle in accordance with the values '   //
     4             'returned by <inquire text extent>.')

      CALL DCHPFV ('EXPLICIT ALIGNMENT FOR HORIZONTAL ANNOTATION ' //
     1             'TEXT: Which annotation text primitive is NOT ' //
     2             'aligned within the dotted annotation text '    //
     3             'extent rectangle on the dashed baseline?',
     4             NUMLIN, PERM(NUMLIN))
      CALL PEMST (102)

C  table of requested and expected alignments and paths to be tested:
C
C                  requested:             | expected:
C       text path  hor-align  vert-align  | hor-align  vert-align
C       algntp     ralgnh     ralgnv      | ealgnh     ealgnv
C       ---------  ---------  ----------  | ---------  ----------
C    1: left       normal     normal      | right      base
C    2: right      normal     normal      | left       base
C    3: left       center     normal      | center     base
C    4: right      normal     top         | left       top
C    5: left       normal     normal      | right      base
      CALL SETVAL ('0,0,2,0,0', RALGNH)
      CALL SETVAL ('0,0,0,1,0', RALGNV)
      CALL SETVAL ('3,1,2,1,3', EALGNH)
      CALL SETVAL ('4,4,4,1,4', EALGNV)

      NUMLIN = 5
C  set up PERM to randomize position
      CALL RNPERM (NUMLIN, PERM)
      YINCR = 1.0 / (NUMLIN+1)
      YTOP  = 1-YINCR

C  scale to fit
      CHHT = MIN (0.7/NTXWD, (0.8*YINCR)/NTXHT)
      CALL PSATCH (CHHT * NPCPWC)

      CALL PSTXCI (1)
      CALL PSPLCI (2)
      CALL NUMLAB (NUMLIN, 0.15, YTOP, YINCR)
      XLO = 0.2
      XHI = XLO + CHHT*NTXWD
      YHALF = CHHT*NTXHT / 2
      XA(1) = XLO
      XA(2) = XHI

C  draw and label 5 identical horizontal annotation text rectangles,
C    using dotted lines, distinct color, dashed baseline,
C    stacked vertically, and labelled 1-5
      DO 500 YMID = YTOP, YINCR/2, -YINCR
         CALL PSLN (PLDOT)
         CALL DRWREC (XLO,XHI, YMID-YHALF, YMID+YHALF)
         CALL PSLN (PLDASH)
         YA(1) = YMID - YHALF + CHHT*VTAB(PABASE)
         YA(2) = YA(1)
         CALL PPL (2,XA,YA)
500   CONTINUE

C  draw in annotation text
      DO 600 IX = 1,NUMLIN
C  set desired y-location based on perm(ix); find bottom of rectangle
         YLO  = YTOP - YHALF - (YINCR*(PERM(IX)-1))
C  calculate txpos = text position, so as to fit annotation text
C  into expected box, using values from ealgnh(ix),ealgnv(ix)
         TXPOSX = XLO + CHHT * HTAB(EALGNH(IX))
         TXPOSY = YLO + CHHT * VTAB(EALGNV(IX))
C  if ix=5 then change txpos to generate incorrect result
         IF (IX .EQ. NUMLIN) THEN
            TXPOSX = TXPOSX + 0.1 * (RNDINT(0,1) - 0.5)
         ENDIF
C  set annotation text alignment = ralgnh(ix), ralgnv(ix)
         CALL PSATAL (RALGNH(IX), RALGNV(IX))
C  set annotation text path = algntp(ix)
         CALL PSATP (ALGNTP(IX))
C  draw annotation text at txpos
         CALL PATR (TXPOSX,TXPOSY, Z,Z, TXSTR)
600   CONTINUE

      CALL SETMSG ('1 2 5 9 19 23 57 58 63 64 65 66 67', 'Implicit ' //
     1             'annotation text alignment attributes should '    //
     2             'affect the position of a horizontal annotation ' //
     3             'text rectangle in accordance with the values '   //
     4             'returned by <inquire text extent>.')

      CALL DCHPFV ('IMPLICIT ALIGNMENT FOR HORIZONTAL ANNOTATION ' //
     1             'TEXT: Which annotation text primitive is NOT ' //
     2             'aligned within the dotted annotation text '    //
     3             'extent rectangle on the dashed baseline?',
     4             NUMLIN, PERM(NUMLIN))
      CALL PEMST (102)

C  use <inquire text extent> on vertical txstr to determine:
C    ntxwd  = nominal width of text extent rectangle
C    ntxht  = nominal height of text extent rectangle
C    vtab,htab = normalized heights and widths
      CALL TXEXAL (2, PDOWN, TXSTR, NTXWD, NTXHT, HTAB, VTAB)

C  table of alignments and paths to be tested:
C
C       hor-align  vert-align  annotation text path
C       algnh      algnv       algntp
C       ---------  ----------  ---------
C    1: right      top         up
C    2: left       cap         down
C    3: center     half        up
C    4: center     base        down
C    5: left       bottom      up
C    6: right      bottom      down
      CALL SETVAL ('3,1,2,2,1,3', ALGNH)
      CALL SETVAL ('1,2,3,4,5,5', ALGNV)
      CALL SETVAL ('2,3,2,3,2,3', ALGNTP)

      NUMLIN = 6
      CALL RNPERM (NUMLIN, PERM)
      XINCR = 1.0 / (NUMLIN+1)
      XLEFT = XINCR
C  scale to fit
      CHHT = MIN (0.7/NTXHT, (0.8*XINCR)/NTXWD)

C  draw and label 6 identical vertical annotation text rectangles,
C    using dotted lines, distinct color,
C    placed adjacent left-to-right and labelled 1-6
      CALL PSTXCI (1)
      CALL PSTXAL (PACENT, PABOTT)
      CALL PSPLCI (2)
      YHI = 0.85
      YLO = YHI - CHHT*NTXHT
      XHALF = CHHT*NTXWD / 2
      YA(1) = YLO
      YA(2) = YHI
C  char height for label
      CALL PSCHH (0.05)
      DO 700 IX = 1,NUMLIN
         XMID = XLEFT + (IX-1)*XINCR
         CALL PSLN (PLDOT)
         CALL DRWREC (XMID-XHALF, XMID+XHALF, YLO,YHI)
         CALL PSLN (PLDASH)
         XA(1) = XMID
         XA(2) = XA(1)
         CALL PPL (2,XA,YA)
         WRITE (DIG2, '(I1,A)') IX, ':'
         CALL PTX (XMID, 0.90, DIG2)
700   CONTINUE

C  char height for annotation text under test
      CALL PSATCH (CHHT * NPCPWC)

C  draw in annotation text
      DO 800 IX = 1,NUMLIN
C  set desired x-location based on perm(ix); find left of rectangle
         XLO  = XLEFT - XHALF + (XINCR*(PERM(IX)-1))
C  calculate txpos = text position, so as to fit annotation text
C    into expected box, using values from algnh(ix),algnv(ix)
         TXPOSX = XLO + CHHT * HTAB(ALGNH(IX))
         TXPOSY = YLO + CHHT * VTAB(ALGNV(IX))

C  if ix=6 then change txpos to generate incorrect result
         IF (IX .EQ. NUMLIN) THEN
            TXPOSY = TXPOSY + 0.1 * (RNDINT(0,1) - 0.5)
         ENDIF
C  set annotation text alignment = algnh(ix), algnv(ix)
         CALL PSATAL (ALGNH(IX), ALGNV(IX))
C  set annotation text path = algntp(ix)
         CALL PSATP (ALGNTP(IX))
C  draw annotation text at txpos
         CALL PATR (TXPOSX,TXPOSY, Z,Z, TXSTR)
800   CONTINUE

      CALL SETMSG ('1 2 5 9 19 23 56 57 58 63 64 65 66', 'Explicit ' //
     1             'annotation text alignment attributes should '    //
     2             'affect the position of a vertical annotation '   //
     3             'text rectangle in accordance with the values '   //
     4             'returned by <inquire text extent>.')
      CALL DCHPFV ('EXPLICIT ALIGNMENT FOR VERTICAL ANNOTATION '   //
     1             'TEXT: Which annotation text primitive is NOT ' //
     2             'aligned within the dotted annotation text '    //
     3             'extent rectangle on the dashed centerline?',
     4             NUMLIN, PERM(NUMLIN))
      CALL PEMST (102)

C  table of requested and expected alignments and paths to be tested:
C
C                  requested:             | expected:
C       text path  hor-align  vert-align  | hor-align  vert-align
C       algntp     ralgnh     ralgnv      | ealgnh     ealgnv
C       ---------  ---------  ----------  | ---------  ----------
C    1: up         normal     normal      | center     base
C    2: down       normal     normal      | center     top
C    3: up         right      normal      | right      base
C    4: down       normal     half        | center     half
C    5: up         normal     normal      | center     base
      CALL SETVAL ('0,0,3,0,0', RALGNH)
      CALL SETVAL ('0,0,0,3,0', RALGNV)
      CALL SETVAL ('2,2,3,2,2', EALGNH)
      CALL SETVAL ('4,1,4,3,4', EALGNV)

      NUMLIN = 5
      CALL RNPERM (NUMLIN, PERM)
      XINCR = 1.0 / (NUMLIN+1)
      XLEFT = XINCR
C  scale to fit
      CHHT = MIN (0.7/NTXHT, (0.8*XINCR)/NTXWD)

C  draw and label 5 identical vertical annotation text rectangles,
C    using dotted lines, distinct color,
C    placed adjacent left-to-right and labelled 1-5
      CALL PSTXCI (1)
      CALL PSTXAL (PACENT, PABOTT)
      CALL PSPLCI (2)
      YHI = 0.85
      YLO = YHI - CHHT*NTXHT
      XHALF = CHHT*NTXWD / 2
C  char height for label
      CALL PSCHH (0.05)
      DO 900 IX = 1,NUMLIN
         XMID = XLEFT + (IX-1)*XINCR
         CALL PSLN (PLDOT)
         CALL DRWREC (XMID-XHALF, XMID+XHALF, YLO,YHI)
         CALL PSLN (PLDASH)
         XA(1) = XMID
         XA(2) = XA(1)
         CALL PPL (2,XA,YA)
         WRITE (DIG2, '(I1,A)') IX, ':'
         CALL PTX (XMID, 0.90, DIG2)
900   CONTINUE

C  char height for annotation text under test
      CALL PSATCH (CHHT * NPCPWC)

C  draw in annotation text
      DO 1000 IX = 1,NUMLIN
C  set desired x-location based on perm(ix); find left of rectangle
         XLO  = XLEFT - XHALF + (XINCR*(PERM(IX)-1))
C  calculate txpos = text position, so as to fit annotation text
C    into expected box, using values from ealgnh(ix),ealgnv(ix)
         TXPOSX = XLO + CHHT * HTAB(EALGNH(IX))
         TXPOSY = YLO + CHHT * VTAB(EALGNV(IX))
C  if ix=5 then change txpos to generate incorrect result
         IF (IX .EQ. NUMLIN) THEN
            TXPOSY = TXPOSY + 0.1 * (RNDINT(0,1) - 0.5)
         ENDIF
C  set annotation text alignment = ralgnh(ix), ralgnv(ix)
         CALL PSATAL (RALGNH(IX), RALGNV(IX))
C  set annotation text path = algntp(ix)
         CALL PSATP (ALGNTP(IX))
C  draw annotation text at txpos
         CALL PATR (TXPOSX,TXPOSY, Z,Z, TXSTR)
1000  CONTINUE

      CALL SETMSG ('1 2 5 9 19 23 57 58 63 64 65 66 67', 'Implicit ' //
     1             'annotation text alignment attributes should '    //
     2             'affect the position of a vertical annotation '   //
     3             'text rectangle in accordance with the values '   //
     4             'returned by <inquire text extent>.')
      CALL DCHPFV ('IMPLICIT ALIGNMENT FOR VERTICAL ANNOTATION '   //
     1             'TEXT: Which annotation text primitive is NOT ' //
     2             'aligned within the dotted annotation text '    //
     3             'extent rectangle on the dashed centerline?',
     4             NUMLIN, PERM(NUMLIN))
      CALL PEMST (102)

666   CONTINUE
C  wrap it up.
      CALL ENDIT
      END

ext: f


!> @file sim_db_mod.f90
!> @brief The Fortran class and functions to use ```sim_db```.

! Copyright (C) 2019 Håkon Austlid Taskén <hakon.tasken@gmail.com>
! Licensed under the MIT License.

module sim_db_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_double, c_bool, &
    c_char, c_size_t, c_null_char, c_loc, c_f_pointer
use, intrinsic :: iso_fortran_env
use sim_db_c_interface
implicit none

private
public :: sim_db, sim_db_add_empty_sim

!> Class to interact with the **sim_db** database.
!>
!> Constructor is an overload of the **sim_db_dtor\*** functions below, which
!> gives the valid types of parameters.
!>
!> Should be called at the very begin of the simulation and
!> **close** should be called at the very end to add the correct metadata and
!> to clean up.
!>
!> For multithreading/multiprocessing each thread/process MUST have its
!> own connection (instance of this class).
type, public :: sim_db
    type(c_ptr), private :: sim_db_ptr
contains
    !> Read parameter from database.
    !>
    !> Overload of the **read_\*** subroutines below, which gives the valid types
    !> of parameters.
    generic :: read => read_int, read_real_sp, read_real_dp, read_string, &
        read_logical, read_int_array, read_real_sp_array, read_real_dp_array, &
        read_string_array, read_logical_array
    procedure :: read_int
    procedure :: read_real_sp
    procedure :: read_real_dp
    procedure :: read_string
    procedure :: read_logical
    procedure :: read_int_array
    procedure :: read_real_sp_array
    procedure :: read_real_dp_array
    procedure :: read_string_array
    procedure :: read_logical_array

    !> Write parameter to database.
    !>
    !> Overload of the **write_\*** below, which gives the valid types of
    !> parameters.
    generic :: write => write_int, write_real_sp, write_real_dp, write_string, &
        write_logical, write_int_array, write_real_sp_array, &
        write_real_dp_array, write_string_array, write_logical_array, &
        write_int_false, write_real_sp_false, write_real_dp_false, &
        write_string_false, write_logical_false, write_int_array_false, &
        write_real_sp_array_false, write_real_dp_array_false, &
        write_string_array_false, write_logical_array_false
    procedure :: write_int
    procedure :: write_real_sp
    procedure :: write_real_dp
    procedure :: write_string
    procedure :: write_logical
    procedure :: write_int_array
    procedure :: write_real_sp_array
    procedure :: write_real_dp_array
    procedure :: write_string_array
    procedure :: write_logical_array
    procedure :: write_int_false
    procedure :: write_real_sp_false
    procedure :: write_real_dp_false
    procedure :: write_string_false
    procedure :: write_logical_false
    procedure :: write_int_array_false
    procedure :: write_real_sp_array_false
    procedure :: write_real_dp_array_false
    procedure :: write_string_array_false
    procedure :: write_logical_array_false

    procedure :: unique_results_dir
    procedure :: unique_results_dir_abs_path
    procedure :: column_exists
    procedure :: is_empty
    procedure :: set_empty
    procedure :: get_id
    procedure :: get_path_proj_root

    !> Save the sha1 hash of the files \p paths_executables to the database.
    !>
    !> Overload of the **update_sha1_executables_\*** functions, which gives
    !> the valid types of parameters.
    generic :: update_sha1_executables => &
        update_sha1_executables_conditionally, &
        update_sha1_executables_unconditionally
    procedure :: update_sha1_executables_conditionally
    procedure :: update_sha1_executables_unconditionally

    procedure :: allow_timeouts
    procedure :: have_timed_out
    procedure :: delete_from_database
    procedure :: close
    final :: sim_db_dtor
end type sim_db

interface sim_db
    module procedure sim_db_ctor
    module procedure sim_db_ctor_with_id
    module procedure sim_db_ctor_without_search
end interface sim_db

interface sim_db_add_empty_sim
    procedure sim_db_add_empty_sim_with_search, &
              sim_db_add_empty_sim_without_search, &
              sim_db_add_empty_sim_without_search_false
end interface sim_db_add_empty_sim

type, private :: c_string
    character(len=:), pointer :: c_str
contains
    procedure, private :: to_c_ptr
    final :: c_string_dtor
end type c_string

interface c_string
    module procedure c_string_ctor
end interface c_string

contains !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!> Connect to the database using the command line arguments containing
!> ```--id 'ID'``` and optionally ```--path_proj_root 'PATH'```. *PATH* is the
!> root directory of the project, where *.sim_db/* is located. If not passed,
!> the current working directory and its parent directories will be searched
!> until *.sim_db/* is found.
!>
!> @param store_metadata **logical, optional** Stores metadata to database if
!> true. Set to 'false' for postprocessing (e.g. visualization) of data from
!> simulation.
function sim_db_ctor(store_metadata) result(sim_database)
    logical, optional, value :: store_metadata
    type(sim_db) :: sim_database

    integer :: i, nargs, len_str
    character(len=100, kind=c_char), dimension(:), allocatable, target :: &
        command_line_arguments
    type(c_ptr), dimension(:), allocatable, target :: argv

    if (.not. present(store_metadata)) store_metadata = .true.

    nargs = command_argument_count()
    allocate(command_line_arguments(nargs))
    allocate(argv(nargs))

    do i = 1, nargs
        call get_command_argument(i, command_line_arguments(i))
        len_str = len_trim(command_line_arguments(i))
        if (len_str >= 100) then
            error stop "ERROR: Command line argument longer than the maximum &
                       &100 characters."
        end if
        command_line_arguments(i)(len_str + 1:len_str + 1) = c_null_char
        argv(i) = c_loc(command_line_arguments(i))
    end do

    if (store_metadata) then
        sim_database%sim_db_ptr = sim_db_ctor_c(nargs, argv)
    else
        sim_database%sim_db_ptr = sim_db_ctor_no_metadata_c(nargs, argv)
    end if

    deallocate(argv)
    deallocate(command_line_arguments)
end function sim_db_ctor

!> @param id **integer, intent(in)** ID number of the simulation paramters in
!> the **sim_db** database.
!> @param store_metadata **logical, optional** Stores metadata to database if
!> true. Set to 'false' for postprocessing (e.g. visualization) of data from
!> simulation.
function sim_db_ctor_with_id(id, store_metadata) result(sim_database)
    integer, value, intent(in) :: id
    logical, optional, value :: store_metadata
    type(sim_db) :: sim_database

    if (.not. present(store_metadata)) store_metadata = .true.

    sim_database%sim_db_ptr = sim_db_ctor_with_id_c(int(id, kind=c_int), &
                                           logical(store_metadata, kind=c_bool))
end function sim_db_ctor_with_id

!> @param path_proj_root **character(len=*), intent(in)** Path to the root
!> directory of the project, where *.sim_db/* is located.
!> @param id **integer, intent(in)** ID number of the simulation paramters in the **sim_db**
!> database.
!> @param store_metadata **logical, optional** Stores metadata to database if
!> true. Set to 'false' for postprocessing (e.g. visualization) of data from
!> simulation.
function sim_db_ctor_without_search(path_proj_root, id, store_metadata) &
        result(sim_database)
    character(len=*), intent(in) :: path_proj_root
    integer, value, intent(in) :: id
    logical, optional, value :: store_metadata
    type(sim_db) :: sim_database

    type(c_string) :: path_proj_root_c_str
    path_proj_root_c_str = c_string(path_proj_root)

    if (.not. present(store_metadata)) store_metadata = .true.

    sim_database%sim_db_ptr = sim_db_ctor_without_search_c( &
            path_proj_root_c_str%to_c_ptr(), int(id, kind=c_int), &
            logical(store_metadata, kind=c_bool))
end function sim_db_ctor_without_search

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] int_value **integer, intent(out)**  Value read from database.
subroutine read_int(self, column, int_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, intent(out) :: int_value

    type(c_string) :: column_c_str
    column_c_str = c_string(column)

    int_value = int(sim_db_read_int_c(self%sim_db_ptr, column_c_str%to_c_ptr()))
end subroutine read_int

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] real_value **real(kind=kind(1.0d0)), intent(out)**  Value read from
!> database.
subroutine read_real_dp(self, column, real_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), intent(out) :: real_value

    type(c_string) :: column_c_str
    column_c_str = c_string(column)

    real_value = real(sim_db_read_double_c(self%sim_db_ptr, &
                      column_c_str%to_c_ptr()), kind(1.0d0))
end subroutine read_real_dp

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] real_value **real, intent(out)** Value read from database.
subroutine read_real_sp(self, column, real_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, intent(out) :: real_value

    real(kind=kind(1.0d0)) real_dp_value

    call read_real_dp(self, column, real_dp_value)
    real_value = real(real_dp_value)
end subroutine read_real_sp

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] string_value **character(len=:), allocatable, intent(out)** Value read from database.
subroutine read_string(self, column, string_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=:), allocatable, intent(out) :: string_value

    type(c_ptr) :: c_str
    character(len=huge(0), kind=c_char), pointer :: f_str
    type(c_string) :: column_c_str
    column_c_str = c_string(column)

    c_str = sim_db_read_string_c(self%sim_db_ptr, column_c_str%to_c_ptr())
    call c_f_pointer(c_str, f_str)
    string_value = f_str(1:index(f_str, c_null_char) - 1)
end subroutine read_string

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] logical_value **logical, intent(out)** Value read from database.
subroutine read_logical(self, column, logical_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, intent(out) :: logical_value

    type(c_string) :: column_c_str
    column_c_str = c_string(column)

    logical_value = sim_db_read_bool_c(self%sim_db_ptr, column_c_str%to_c_ptr())
end subroutine read_logical

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] int_array **integer, dimension(:), allocatable, intent(out)** Value read from database.
subroutine read_int_array(self, column, int_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, dimension(:), allocatable, intent(out) :: int_array

    type(sim_db_vec) :: c_int_vec
    integer(kind=c_int), dimension(:), pointer :: int_array_ptr
    type(c_string) :: column_c_str

    column_c_str = c_string(column)
    c_int_vec = sim_db_read_int_vec_c(self%sim_db_ptr, column_c_str%to_c_ptr())
    call c_f_pointer(c_int_vec%array, int_array_ptr, [c_int_vec%size])
    int_array = int_array_ptr
end subroutine read_int_array

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] real_array **real, dimension(:), allocatable, intent(out)** Value read from database.
subroutine read_real_sp_array(self, column, real_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, dimension(:), allocatable, intent(out) :: real_array

    type(sim_db_vec) :: c_double_vec
    real(kind=c_double), dimension(:), pointer :: real_array_ptr
    type(c_string) :: column_c_str

    column_c_str = c_string(column)
    c_double_vec = sim_db_read_double_vec_c(self%sim_db_ptr, column_c_str%to_c_ptr())
    call c_f_pointer(c_double_vec%array, real_array_ptr, [c_double_vec%size])
    real_array = real_array_ptr
end subroutine read_real_sp_array

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] real_array **real(kind=kind(1.0d0)), dimension(:), allocatable, intent(out)** Value read from database.
subroutine read_real_dp_array(self, column, real_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), dimension(:), allocatable, intent(out) :: real_array

    type(sim_db_vec) :: c_double_vec
    real(kind=c_double), dimension(:), pointer :: real_array_ptr
    type(c_string) :: column_c_str

    column_c_str = c_string(column)
    c_double_vec = sim_db_read_double_vec_c(self%sim_db_ptr, &
                                            column_c_str%to_c_ptr())
    call c_f_pointer(c_double_vec%array, real_array_ptr, [c_double_vec%size])
    real_array = real_array_ptr
end subroutine read_real_dp_array

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out]  **allocatable, intent(out) :: string_array character(len(:), dimension(** Value read from databas.
subroutine read_string_array(self, column, string_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=:), dimension(:), allocatable, intent(out) :: string_array

    type(sim_db_vec) :: c_string_vec
    type(c_ptr), dimension(:), pointer :: c_str_array_ptr
    character(len=huge(0), kind=c_char), pointer :: f_str
    integer :: i, len_str, max_len_str
    type(c_string) :: column_c_str

    column_c_str = c_string(column)
    c_string_vec = sim_db_read_string_vec_c(self%sim_db_ptr, &
                                            column_c_str%to_c_ptr())
    call c_f_pointer(c_string_vec%array, c_str_array_ptr, [c_string_vec%size])
    max_len_str = 0
    do i = 1, size(c_str_array_ptr)
        call c_f_pointer(c_str_array_ptr(i), f_str)
        len_str = index(f_str, c_null_char)
        if (len_str > max_len_str) then
            max_len_str = len_str
        end if
    end do
    allocate(character(max_len_str) :: string_array(c_string_vec%size))
    do i = 1, size(string_array)
        call c_f_pointer(c_str_array_ptr(i), f_str)
        string_array(i) = f_str(1:index(f_str, c_null_char) - 1)
    end do
end subroutine read_string_array

!> @param[in] column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param[out] logical_array **logical, dimension(:), allocatable, intent(out)**
!> Value read from database.
subroutine read_logical_array(self, column, logical_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, dimension(:), allocatable, intent(out) :: logical_array

    type(sim_db_vec) :: c_bool_vec
    logical(kind=c_bool), dimension(:), pointer :: logical_array_ptr
    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    c_bool_vec = sim_db_read_bool_vec_c(self%sim_db_ptr, column_c_str%to_c_ptr())
    call c_f_pointer(c_bool_vec%array, logical_array_ptr, [c_bool_vec%size])
    logical_array = logical_array_ptr
end subroutine read_logical_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param int_value **integer, intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_int(self, column, int_value, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, intent(in) :: int_value
    logical, value :: only_if_empty

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    call sim_db_write_int_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
        int(int_value, kind=c_int), logical(only_if_empty, kind=c_bool))
end subroutine write_int

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param int_value **integer, intent(in)** To be written to database.
subroutine write_int_false(self, column, int_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, intent(in) :: int_value
    call write_int(self, column, int_value, .false.)
end subroutine write_int_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_value **real, intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_real_sp(self, column, real_value, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, intent(in) :: real_value
    logical, value :: only_if_empty

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    call sim_db_write_double_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
        real(real_value, kind=c_double), logical(only_if_empty, kind=c_bool))
end subroutine write_real_sp

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_value **real, intent(in)** To be written to database.
subroutine write_real_sp_false(self, column, real_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, intent(in) :: real_value
    call write_real_sp(self, column, real_value, .false.)
end subroutine write_real_sp_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_value **real(kind=kind(1.0d0)), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_real_dp(self, column, real_value, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), intent(in) :: real_value
    logical, value :: only_if_empty

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    call sim_db_write_double_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
        real(real_value, kind=c_double), logical(only_if_empty, kind=c_bool))
end subroutine write_real_dp

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_value **real(kind=kind(1.0d0)), intent(in)** To be written to database.
subroutine write_real_dp_false(self, column, real_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), intent(in) :: real_value
    call write_real_dp(self, column, real_value, .false.)
end subroutine write_real_dp_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param string_value **character(len=*), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_string(self, column, string_value, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=*), intent(in) :: string_value
    logical, value :: only_if_empty

    type(c_string) :: column_c_str, string_value_c_str
    column_c_str = c_string(column)
    string_value_c_str = c_string(string_value)
    call sim_db_write_string_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
        string_value_c_str%to_c_ptr(), logical(only_if_empty, kind=c_bool))
end subroutine write_string

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param string_value **character(len=*), intent(in)** To be written to database.
subroutine write_string_false(self, column, string_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=*), intent(in) :: string_value
    call write_string(self, column, string_value, .false.)
end subroutine write_string_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param logical_value **logical, intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_logical(self, column, logical_value, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, intent(in) :: logical_value
    logical, value :: only_if_empty

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    call sim_db_write_bool_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
        logical(logical_value, kind=c_bool), logical(only_if_empty, kind=c_bool))
end subroutine write_logical

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param logical_value **logical, intent(in)** To be written to database.
subroutine write_logical_false(self, column, logical_value)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, intent(in) :: logical_value
    call write_logical(self, column, logical_value, .false.)
end subroutine write_logical_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param int_array **integer, dimension(:), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_int_array(self, column, int_array, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, dimension(:), intent(in) :: int_array
    logical, intent(in) :: only_if_empty

    integer(c_int), dimension(:), allocatable, target :: c_int_array
    integer :: i
    type(c_string) :: column_c_str
    if (c_int == kind(1)) then
            c_int_array = int_array
    else
        allocate(c_int_array(size(int_array)))
        do i = 1, size(c_int_array)
            c_int_array(i) = int(int_array(i), kind=c_int)
        end do
    end if
    column_c_str = c_string(column)
    call sim_db_write_int_array_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
                                     c_loc(c_int_array), size(c_int_array), &
                                     logical(only_if_empty, kind=c_bool))
end subroutine write_int_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param int_array **integer, dimension(:), target, intent(in)** To be written to database.
subroutine write_int_array_false(self, column, int_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    integer, dimension(:), target, intent(in) :: int_array
    call write_int_array(self, column, int_array, .false.)
end subroutine write_int_array_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_array **real(kind=kind(1.0d0)), dimension(:), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_real_dp_array(self, column, real_array, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), dimension(:), intent(in) :: real_array
    logical, intent(in) :: only_if_empty

    real(c_double), dimension(:), allocatable, target :: c_double_array
    integer :: i
    type(c_string) :: column_c_str
    if (c_double == kind(1.0d0)) then
            c_double_array = real_array
    else
        allocate(c_double_array(size(real_array)))
        do i = 1, size(c_double_array)
            c_double_array(i) = real(real_array(i), kind=c_double)
        end do
    end if
    column_c_str = c_string(column)
    call sim_db_write_double_array_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
                                  c_loc(c_double_array), size(c_double_array), &
                                     logical(only_if_empty, kind=c_bool))
end subroutine write_real_dp_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_array **real(kind=kind(1.0d0)), dimension(:), target, intent(in)** To be written to database.
subroutine write_real_dp_array_false(self, column, real_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real(kind=kind(1.0d0)), dimension(:), target, intent(in) :: real_array
    call write_real_dp_array(self, column, real_array, .false.)
end subroutine write_real_dp_array_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_array **real, dimension(:), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_real_sp_array(self, column, real_array, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, dimension(:), intent(in) :: real_array
    logical, intent(in) :: only_if_empty

    real(c_double), dimension(:), allocatable, target :: c_double_array
    integer :: i
    type(c_string) :: column_c_str
    if (c_double == kind(1.0)) then
        c_double_array = real_array
    else
        allocate(c_double_array(size(real_array)))
        do i = 1, size(c_double_array)
            c_double_array(i) = real(real_array(i), kind=c_double)
        end do
    end if
    column_c_str = c_string(column)
    call sim_db_write_double_array_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
                                  c_loc(c_double_array), size(c_double_array), &
                                     logical(only_if_empty, kind=c_bool))
end subroutine write_real_sp_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param real_array **real, dimension(:), intent(in)** To be written to database.
subroutine write_real_sp_array_false(self, column, real_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    real, dimension(:), intent(in) :: real_array
    call write_real_sp_array(self, column, real_array, .false.)
end subroutine write_real_sp_array_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param string_array **character(len=*), dimension(:), intent(in)** n=*), dimension**(To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_string_array(self, column, string_array, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=*), dimension(:), intent(in) :: string_array
    logical, intent(in) :: only_if_empty

    type(c_ptr), dimension(:), allocatable, target :: c_ptr_array
    integer :: i
    type(c_string) :: c_str, column_c_str

    allocate(c_ptr_array(size(string_array)))
    do i = 1, size(string_array)
        c_str = c_string(string_array(i))
        c_ptr_array(i) = c_str%to_c_ptr()
    end do

    column_c_str = c_string(column)
    column_c_str = c_string(column)
    call sim_db_write_string_array_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
                                     c_loc(c_ptr_array), size(string_array), &
                                     logical(only_if_empty, kind=c_bool))

    deallocate(c_ptr_array)
end subroutine write_string_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param intent **character(len=*), dimension**(To be written to database.
subroutine write_string_array_false(self, column, string_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    character(len=*), dimension(:), intent(in) :: string_array
    call write_string_array(self, column, string_array, .false.)
end subroutine write_string_array_false

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param logical_array **logical, dimension(:), intent(in)** To be written to database.
!> @param only_if_empty **logical** If .true., it will only write to the
!> database if the simulation's entry under 'column' is empty. Will avoid
!> potential timeouts for concurrect applications.
subroutine write_logical_array(self, column, logical_array, only_if_empty)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, dimension(:), intent(in) :: logical_array
    logical, intent(in) :: only_if_empty

    logical(c_bool), dimension(:), allocatable, target :: c_bool_array
    integer :: i
    type(c_string) :: column_c_str
    if (c_bool == kind(.true.)) then
            c_bool_array = logical_array
    else
        allocate(c_bool_array(size(logical_array)))
        do i = 1, size(c_bool_array)
            c_bool_array(i) = logical(logical_array(i), kind=c_bool)
        end do
    end if

    column_c_str = c_string(column)
    c_bool_array = logical_array
    call sim_db_write_bool_array_c(self%sim_db_ptr, column_c_str%to_c_ptr(), &
                                     c_loc(c_bool_array), size(c_bool_array), &
                                     logical(only_if_empty, kind=c_bool))
end subroutine write_logical_array

!> @param column **character(len=*), intent(in)** Name of the parameter and
!> column in the database.
!> @param logical_array **logical, dimension(:), intent(in)** To be written to database.
subroutine write_logical_array_false(self, column, logical_array)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical, dimension(:), intent(in) :: logical_array
    call write_logical_array(self, column, logical_array, .false.)
end subroutine write_logical_array_false

!> Get path to subdirectory in \p path_directory unique to simulation.
!>
!> The subdirectory will be named 'date_time_name_id' and is intended to
!> store results in. If 'results_dir' in the database is empty, a new and
!> unique directory is created and the path stored in 'results_dir'.
!> Otherwise the path in 'results_dir' is just returned.
!>
!> @param path_directory **character(len=*), intent(in)** Path to where the new
!> directory is created. If it starts with 'root/', that part will be replaced
!> with the full path to the root directory of the project.
!> @return **character(len=:), allocatable** Path to new subdirectory.
function unique_results_dir(self, path_to_dir)
    class(sim_db)::self
    character(len=*), intent(in) :: path_to_dir
    character(len=:), allocatable :: unique_results_dir

    type(c_ptr) :: c_str
    character(len=huge(0), kind=c_char), pointer :: f_str
    type(c_string) :: path_c_str
    path_c_str = c_string(path_to_dir)

    c_str = sim_db_unique_results_dir_c(self%sim_db_ptr, path_c_str%to_c_ptr())
    call c_f_pointer(c_str, f_str)
    unique_results_dir = f_str(1:index(f_str, c_null_char) - 1)
end function unique_results_dir

!> Get path to subdirectory in \p abs_path_to_dir unique to simulation.
!>
!> The subdirectory will be named 'date_time_name_id' and is intended to store
!> results in. If 'results_dir' in the database is empty, a new and unique
!> directory is created and the path stored in 'results_dir'. Otherwise the
!> path in 'results_dir' is just returned.
!>
!> @param abs_path_to_dir **character(len=*), intent(in)** Absolute path to
!> where the new directory is created.
!> @return **character(len=:), allocatable** Path to new subdirectory.
function unique_results_dir_abs_path(self, abs_path_to_dir)
    class(sim_db)::self
    character(len=*), intent(in) :: abs_path_to_dir
    character(len=:), allocatable :: unique_results_dir_abs_path

    type(c_ptr) :: c_str
    character(len=huge(0), kind=c_char), pointer :: f_str
    type(c_string) :: path_c_str
    path_c_str = c_string(abs_path_to_dir)

    c_str = sim_db_unique_results_dir_abs_path_c(self%sim_db_ptr, &
                                                 path_c_str%to_c_ptr())
    call c_f_pointer(c_str, f_str)
    unique_results_dir_abs_path = f_str(1:index(f_str, c_null_char) - 1)
end function unique_results_dir_abs_path

!> Return true if \p column is a column in the database.
!>
!> @param column **character(len=*), intent(in)** Name of column in database.
function column_exists(self, column)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical :: column_exists

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    column_exists = logical(sim_db_column_exists_c(self%sim_db_ptr, &
                                                   column_c_str%to_c_ptr()))
end function column_exists

!> Return true if entry in database under \p column is empty.
!>
!> @param column **character(len=*), intent(in)** Name of column in database.
function is_empty(self, column)
    class(sim_db) :: self
    character(len=*), intent(in) :: column
    logical :: is_empty

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    is_empty = sim_db_is_empty_c(self%sim_db_ptr, column_c_str%to_c_ptr())
end function is_empty

!> Set entry under \p column in database to empty.
!>
!> @param column **character(len=*), intent(in)** Name of column in database.
subroutine set_empty(self, column)
    class(sim_db) :: self
    character(len=*), intent(in) :: column

    type(c_string) :: column_c_str
    column_c_str = c_string(column)
    call sim_db_set_empty_c(self%sim_db_ptr, column_c_str%to_c_ptr())
end subroutine set_empty

!> Return ID number of simulation in the database that is connected.
function get_id(self) result(id)
    class(sim_db) :: self
    integer :: id
    id = int(sim_db_get_id_c(self%sim_db_ptr))
end function get_id

!> Return path to root directory of the project, where *.sim_db/* is
!> located.
function get_path_proj_root(self) result(path_proj_root)
    class(sim_db) :: self
    character(len=:), allocatable :: path_proj_root

    type(c_ptr) :: c_str
    character(len=huge(0)), pointer :: f_str
    c_str = sim_db_get_path_proj_root_c(self%sim_db_ptr)
    call c_f_pointer(c_str, f_str)
    path_proj_root = f_str(1:index(f_str, c_null_char) - 1)
end function get_path_proj_root

!> @param paths_executables **character(len=:), dimension(:), allocatable,
!> intent(in)** Paths to executable files.
!> @param len Length of \p paths_executables.
!> @param **logical, intent(in)** only_if_empty If True, it will only write to
!> the database if the simulation's entry under 'sha1_executables' is empty.
!> Will avoid any potential timeouts for concurrect applications.
subroutine update_sha1_executables_conditionally(self, paths_executables, &
                                                 only_if_empty)
    class(sim_db) :: self
    character(len=:), dimension(:), allocatable, intent(in) :: paths_executables
    logical, intent(in) :: only_if_empty

    type(c_ptr), dimension(:), allocatable, target :: c_ptr_array
    integer :: i
    type(c_string) :: c_str

    allocate(c_ptr_array(size(paths_executables)))
    do i = 1, size(paths_executables)
        c_str = c_string(paths_executables(i))
        c_ptr_array(i) = c_str%to_c_ptr()
    end do

    call sim_db_update_sha1_executables_c(self%sim_db_ptr, c_ptr_array, &
        int(size(c_ptr_array), kind=c_size_t), &
        logical(only_if_empty, kind=c_bool))
end subroutine update_sha1_executables_conditionally

!> @param paths_executables **character(len=:), dimension(:), allocatable,
!> intent(in)** Paths to executable files.
!> @param len Length of \p paths_executables.
subroutine update_sha1_executables_unconditionally(self, paths_executables)
    class(sim_db) :: self
    character(len=:), dimension(:), allocatable, intent(in) :: paths_executables
    call update_sha1_executables_conditionally(self, paths_executables, .false.)
end subroutine update_sha1_executables_unconditionally

!> Allow timeouts to occure without exiting if set to true.
!>
!> A timeout occures after waiting more than 5 seconds to access the database
!> because other threads/processes are busy writing to it. **sim_db**
!> will exit with an error in that case, unless allow timeouts is set to true.
!> It is false by default. If allowed and a timeout occures the called
!> funciton will have had no effect.
subroutine allow_timeouts(self, is_allowing_timeouts)
    class(sim_db) :: self
    logical, intent(in) :: is_allowing_timeouts
    call sim_db_allow_timeouts_c(self%sim_db_ptr, &
                                 logical(is_allowing_timeouts, kind=c_bool))
end subroutine allow_timeouts

!> Checks if a timeout have occured since last call to this function.
function have_timed_out(self)
    class(sim_db) :: self
    logical :: have_timed_out
    have_timed_out = logical(sim_db_have_timed_out_c(self%sim_db_ptr))
end function have_timed_out

!> Delete simulation from database.
subroutine delete_from_database(self)
    class(sim_db) :: self
    call sim_db_delete_from_database_c(self%sim_db_ptr)
end subroutine delete_from_database

!> Add metadate for 'used_walltime' to database and update 'status' to
!> 'finished' and cleans up.
subroutine close(self)
    class(sim_db) :: self
    call sim_db_dtor_c(self%sim_db_ptr)
end subroutine close

subroutine sim_db_dtor(self)
    type(sim_db) :: self
    call sim_db_dtor_c(self%sim_db_ptr)
end subroutine sim_db_dtor

type(sim_db) function sim_db_add_empty_sim_with_search(store_metadata)
    logical, optional, value :: store_metadata

    type(c_ptr) :: empty_sim_db
    if (.not. present(store_metadata)) store_metadata = .false.

    empty_sim_db = sim_db_add_empty_sim_c(logical(store_metadata, kind=c_bool))
    sim_db_add_empty_sim_with_search%sim_db_ptr = empty_sim_db
end function sim_db_add_empty_sim_with_search

!> Add empty simulation to database and return a type(sim_db) connected to it.
!>
!> The current working directory and its parent directories will be searched
!> until *.sim_db/* is found.
!>
!> @return **type(sim_db)** of the added simulation.
!> @param store_metadata **logical** Stores metadata if true. Set to 'false' for
!> postprocessing (e.g. visualization) of data from simulation.
type(sim_db) function sim_db_add_empty_sim_without_search(path_proj_root, &
                                                      store_metadata)
    character(len=*), intent(in) :: path_proj_root
    logical, value :: store_metadata

    type(c_string) :: path_proj_root_c_str
    type(c_ptr) :: empty_sim_db

    path_proj_root_c_str = c_string(path_proj_root)
    empty_sim_db = sim_db_add_empty_sim_without_search_c( &
        path_proj_root_c_str%to_c_ptr(), logical(store_metadata, kind=c_bool))
    sim_db_add_empty_sim_without_search%sim_db_ptr = empty_sim_db
end function sim_db_add_empty_sim_without_search

!> Add empty simulation to database and return a type(sim_db) connected to it.
!>
!> The current working directory and its parent directories will be searched
!> until *.sim_db/* is found.
!>
!> @return **type(sim_db)** of the added simulation.
!> @param path_proj_root **character(len=*), intent(in)** Path to root
!> directory of the project, where *.sim_db/* is located.
!> @param store_metadata **logical** Stores metadata if true. Set to 'false' for
!> postprocessing (e.g. visualization) of data from simulation.
type(sim_db) function sim_db_add_empty_sim_without_search_false(path_proj_root)
    character(len=*), intent(in) :: path_proj_root
    sim_db_add_empty_sim_without_search_false = &
        sim_db_add_empty_sim_without_search(path_proj_root, .false.)
end function sim_db_add_empty_sim_without_search_false

type(c_string) function c_string_ctor(f_string) result(obj)
    character(len=*), intent(in) :: f_string

    integer :: len_str
    len_str = len_trim(f_string)
    allocate(character(len=(len_str + 1), kind=c_char) :: obj%c_str)
    obj%c_str = f_string
    obj%c_str(len_str + 1:len_str + 1) = c_null_char
end function c_string_ctor

type(c_ptr) function to_c_ptr(self)
    class(c_string) :: self
    to_c_ptr = c_loc(self%c_str)
end function to_c_ptr

subroutine c_string_dtor(self)
    type(c_string) :: self
    deallocate(self%c_str)
end subroutine c_string_dtor

end module sim_db_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


text:
  !! Local Data
  INTEGER :: outer_counter, inner_counter
  INTEGER :: elements_per_inner

  !! Allocate Space For Result
  norm_per_column = 0

  !! Iterate Over Local Data
  DO outer_counter = 1, this%columns
     elements_per_inner = this%outer_index(outer_counter+1) - &
          & this%outer_index(outer_counter)
     DO inner_counter = 1, elements_per_inner
        temp_value = this%values(this%outer_index(outer_counter)+ &
             & inner_counter)
        norm_per_column(outer_counter) = norm_per_column(outer_counter) + &
             & ABS(temp_value)
     END DO
  END DO

max_stars_repo_name: Kokookster/NTPoly

max_issues_repo_name: omni-compiler/NTPoly

max_forks_repo_name: omni-compiler/NTPoly


text:
program s17

  integer, parameter :: k=selected_int_kind(10)
  integer a

! kind disappears
  a = 123_k

end program s17

max_stars_repo_name: xevolver/xevxml

max_issues_repo_name: xevolver/xevxml

max_forks_repo_name: xevolver/xevxml


text:
      PROGRAM MPEX06
C
C This program produces a single frame showing satellite views
C of the globe, each rotated by a different angle.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
        PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C Define the label for the top of the map.
C
      CHARACTER*27 PLBL
C
      DATA PLBL / 'THE EARTH IS SPINNING, TOTO' /
C
C Open GKS.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Set the outline-dataset parameter.
C
      CALL MAPSTC ('OU','PS')
C
C Use a satellite-view projection.
C
      CALL MAPSTR ('SA',1.25)
C
C Aim the camera 15 degrees away from straight down.
C
      CALL MAPSTI ('S1',15)
C
C Turn off the perimeter and reduce the number of grid lines.
C
      CALL MAPSTI ('PE',0)
      CALL MAPSTI ('GR',15)
C
C Center the first map over Kansas.  Rotate by 0 degrees and look
C to the upper left.
C
      CALL MAPPOS (.05,.475,.525,.95)
      CALL MAPROJ ('SV',38.,-98.,0.)
      CALL MAPSTI ('S2',135)
      CALL MAPDRW
C
C Repeat, but rotate by 90 degrees and look to the upper right.
C
      CALL MAPPOS (.525,.95,.525,.95)
      CALL MAPROJ ('SV',38.,-98.,90.)
      CALL MAPSTI ('S2',45)
      CALL MAPDRW
C
C Repeat, but rotate by 180 degrees and look to the lower left.
C
      CALL MAPPOS (.05,.475,.05,.475)
      CALL MAPROJ ('SV',38.,-98.,180.)
      CALL MAPSTI ('S2',-135)
      CALL MAPDRW
C
C Repeat, but rotate by 270 degrees and look to the lower right.
C
      CALL MAPPOS (.525,.95,.05,.475)
      CALL MAPROJ ('SV',38.,-98.,270.)
      CALL MAPSTI ('S2',-45)
      CALL MAPDRW
C
C Put the label at the top of the plot ...
C
      CALL SET (0.,1.,0.,1.,0.,1.,0.,1.,1)
      CALL PWRIT (.5,.975,PLBL,27,2,0,0)
C
C and the ones below each sub-plot.
C
      CALL PWRIT (.2625,.5,'ROTA = 0',8,1,0,0)
      CALL PWRIT (.7375,.5,'ROTA = 90',9,1,0,0)
      CALL PWRIT (.2625,.025,'ROTA = 180',10,1,0,0)
      CALL PWRIT (.7375,.025,'ROTA = 270',10,1,0,0)
C
C Draw a boundary around the edge of the plotter frame.
C
      CALL BNDARY
C
C Advance the frame.
C
      CALL FRAME
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
C Done.
C
      STOP
C
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

subroutine test1
  !ERROR: Generic interface 'foo' has both a function and a subroutine
  interface foo
    subroutine s1(x)
    end subroutine
    subroutine s2(x, y)
    end subroutine
    function f()
    end function
  end interface
end subroutine

subroutine test2
  !ERROR: Generic interface 'foo' has both a function and a subroutine
  interface foo
    function f1(x)
    end function
    subroutine s()
    end subroutine
    function f2(x, y)
    end function
  end interface
end subroutine

module test3
  !ERROR: Generic interface 'foo' has both a function and a subroutine
  interface foo
    module procedure s
    module procedure f
  end interface
contains
  subroutine s(x)
  end subroutine
  function f()
  end function
end module

subroutine test4
  type foo
  end type
  !ERROR: Generic interface 'foo' may only contain functions due to derived type with same name
  interface foo
    subroutine s()
    end subroutine
  end interface
end subroutine

subroutine test5
  interface foo
    function f1()
    end function
  end interface
  interface bar
    subroutine s1()
    end subroutine
    subroutine s2(x)
    end subroutine
  end interface
  !ERROR: Cannot call function 'foo' like a subroutine
  call foo()
  !ERROR: Cannot call subroutine 'bar' like a function
  x = bar()
end subroutine


text:
module A {

  module B {

    @ Annotation line 1
    @ Annotation line 2
    enum OK {
      X @< Annotation line 1
        @< Annotation line 2
      Y
      Z
    }

  }

}

ext: fpp

max_stars_repo_name: kevin-f-ortega/fpp

max_issues_repo_name: kevin-f-ortega/fpp

max_forks_repo_name: kevin-f-ortega/fpp


! { dg-do compile }
module eq
   implicit none
   integer :: n1, n2
   integer, dimension(2) :: a
   equivalence (a(1), n1)
   equivalence (a(2), n2)
   common /a/ a
end module eq

module m
   use eq
   implicit none
   type, public :: t
     integer :: i
   end type t
end module m

module p
   implicit none
   contains
   pure integer function d(h)
     use m
     implicit none
     integer, intent(in) :: h
     d = h
   end function
end module p

module q
   implicit none
   contains
   pure integer function d(h)
     use m, only : t
     implicit none
     integer, intent(in) :: h
     d = h
   end function
end module q

module r
   implicit none
   contains
   pure integer function d(h)
     use m, only : a          ! { dg-error "cannot be an EQUIVALENCE object" }
     implicit none
     integer, intent(in) :: h
     d = h
   end function
end module r


! missing - please submit an example


text:
program reduction
  implicit none
  real :: r, x, beta_mod, z, eps_E
  integer :: i, j
  real, dimension(10) :: a, b

  do i = 1, 10
     eps_E = toMask(iand(b(i+1), .true.))
     if (.true.) then
        if (.true.) then
        else if (.true.) then
               beta_mod = -6/((eps_E+1)*5+2*3)
               != stencil forward(depth=1, dim=1) :: b
               a(i) = (b(i) + beta_mod + eps_E*b(i)) / 2
               z = a(i)
               != access readOnce, pointed(dim=1) :: a
               r = max(r, z)
        end if
     end if
  end do

end program reduction

max_stars_repo_name: raehik/camfort

max_issues_repo_name: apthorpe/camfort

max_forks_repo_name: raehik/camfort


text:
module PDEelliptic

!! Various tools for solving elliptic partial differential equations - uses MUMPS, scalapack, lapack, openmpi, and blas

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit, stdout=>output_unit
use mumps_interface, only : mumps_struc, mumps_exec
use mpimod, only: mpi_comm_world
use phys_consts, only: wp, debug

implicit none (type, external)
private
public :: elliptic3D_cart,elliptic2D_cart,elliptic2D_polarization,elliptic2D_polarization_periodic,&
  elliptic_workers, check_mumps_status, quiet_mumps

interface ! elliptic2d.f90

module function elliptic2D_polarization(srcterm,SigP2,SigP3,SigH,gradSigH2,gradSigH3,Cm,v2,v3,Vminx2,Vmaxx2,Vminx3,Vmaxx3,dt,dx1, &
  dx1i,dx2all,dx2iall,dx3all,dx3iall,Phi0,perflag,it)
real(wp), dimension(:,:), intent(in) :: srcterm,SigP2,SigP3,SigH,Cm,gradSigH2,gradSigH3,v2,v3
!! ZZZ - THESE WILL NEED TO BE MODIFIED CONDUCTIVITIES, AND WE'LL NEED THREE OF THEM
real(wp), dimension(:), intent(in) :: Vminx2,Vmaxx2
real(wp), dimension(:), intent(in) :: Vminx3,Vmaxx3
real(wp), intent(in) :: dt
real(wp), dimension(0:), intent(in) :: dx1         !backward diffs start at index zero due to ghost cells
real(wp), dimension(:), intent(in) :: dx1i         !centered diffs do not include any ghost cells
real(wp), dimension(0:), intent(in) :: dx2all
real(wp), dimension(:), intent(in) :: dx2iall
real(wp), dimension(0:), intent(in) :: dx3all
real(wp), dimension(:), intent(in) :: dx3iall
real(wp), dimension(:,:), intent(in) :: Phi0
logical, intent(in) :: perflag
integer, intent(in) :: it
real(wp), dimension(size(SigP2,1),size(SigP2,2)) :: elliptic2D_polarization
end function elliptic2D_polarization

module function elliptic2D_polarization_periodic(srcterm,SigP,SigH,gradSigH2,gradSigH3,Cm,v2,v3,Vminx2,Vmaxx2, &
    Vminx3,Vmaxx3,dt,dx1,dx1i,dx2all,dx2iall,dx3all,dx3iall,Phi0,perflag,it)
real(wp), dimension(:,:), intent(in) :: srcterm,SigP,SigH,gradSigH2,gradSigH3,Cm,v2,v3
real(wp), dimension(:), intent(in) :: Vminx2,Vmaxx2
real(wp), dimension(:), intent(in) :: Vminx3,Vmaxx3
real(wp), intent(in) :: dt
real(wp), dimension(0:), intent(in) :: dx1         !backward diffs start at index zero due to ghost cells
real(wp), dimension(:), intent(in) :: dx1i         !centered diffs do not include any ghost cells
real(wp), dimension(0:), intent(in) :: dx2all
real(wp), dimension(:), intent(in) :: dx2iall
real(wp), dimension(0:), intent(in) :: dx3all
real(wp), dimension(:), intent(in) :: dx3iall
real(wp), dimension(:,:), intent(in) :: Phi0
logical, intent(in) :: perflag
integer, intent(in) :: it
real(wp), dimension(size(SigP,1),size(SigP,2)) :: elliptic2D_polarization_periodic
end function elliptic2D_polarization_periodic

module function elliptic2D_cart(srcterm,sig0,sigP,Vminx1,Vmaxx1,Vminx3,Vmaxx3,&
  dx1,dx1i,dx3all,dx3iall,flagdirich,perflag,gridflag,it)
real(wp), dimension(:,:,:), intent(in) :: srcterm,sig0,sigP   !arrays passed in will still have full rank 3
real(wp), dimension(:,:), intent(in) :: Vminx1,Vmaxx1
real(wp), dimension(:,:), intent(in) :: Vminx3,Vmaxx3
real(wp), dimension(0:), intent(in) :: dx1         !backward diffs start at index zero due to ghost cells
real(wp), dimension(:), intent(in) :: dx1i         !centered diffs do not include any ghost cells
real(wp), dimension(0:), intent(in) :: dx3all
real(wp), dimension(:), intent(in) :: dx3iall
integer, intent(in) :: flagdirich
logical, intent(in) :: perflag
integer, intent(in) :: gridflag
integer, intent(in) :: it
real(wp), dimension(size(sig0,1),1,size(sig0,3)) :: elliptic2D_cart
end function elliptic2D_cart

end interface

interface ! elliptic3d

module function elliptic3D_cart(srcterm,Ac,Bc,Cc,Dc,Ec,Fc,Vminx1,Vmaxx1,Vminx2,Vmaxx2,Vminx3,Vmaxx3, &
  dx1,dx1i,dx2all,dx2iall,dx3all,dx3iall,flagdirich,perflag,it)
real(wp), dimension(:,:,:), intent(in) :: srcterm,Ac,Bc,Cc,Dc,Ec,Fc
real(wp), dimension(:,:), intent(in) :: Vminx1,Vmaxx1
real(wp), dimension(:,:), intent(in) :: Vminx2,Vmaxx2
real(wp), dimension(:,:), intent(in) :: Vminx3,Vmaxx3
real(wp), dimension(0:), intent(in) :: dx1         !backweard diffs start at index zero due to ghost cells
real(wp), dimension(:), intent(in) :: dx1i         !centered diffs do not include any ghost cells
real(wp), dimension(0:), intent(in) :: dx2all
real(wp), dimension(:), intent(in) :: dx2iall
real(wp), dimension(0:), intent(in) :: dx3all
real(wp), dimension(:), intent(in) :: dx3iall
integer, intent(in) :: flagdirich
logical, intent(in) :: perflag
integer, intent(in) :: it
real(wp), dimension(size(srcterm,1),size(srcterm,2),size(srcterm,3)) :: elliptic3D_cart
end function elliptic3D_cart

end interface

integer, dimension(:), pointer, protected, save :: mumps_perm   !cached permutation, unclear whether save is necessary...

contains

subroutine quiet_mumps(obj)
!! this must be called AFTER the first mumps call that had job=-1
!! Needs Mumps >= 5.2 to actually take effect, does nothing on older MUMPS
!! it stops the 100's of megabytes of logging console text, probably speeding up as well

type(MUMPS_STRUC), intent(inout) :: obj

obj%icntl(1) = stderr  ! error messages
obj%icntl(2) = stdout !  diagnosic, statistics, and warning messages
obj%icntl(3) = stdout! ! global info, for the host (myid==0)
obj%icntl(4) = 1           ! default is 2, this reduces verbosity

end subroutine quiet_mumps

subroutine elliptic_workers()
!! ALLOWS WORKERS TO ENTER MUMPS SOLVES

type(MUMPS_STRUC) :: mumps_par

!FIRE UP MUMPS
mumps_par%COMM = MPI_COMM_WORLD
mumps_par%JOB = -1
mumps_par%SYM = 0
mumps_par%PAR = 1

call MUMPS_exec(mumps_par)

call quiet_mumps(mumps_par)

!ROOT WILL LOAD OUR PROBLEM

!SOLVE (ALL WORKERS NEED TO SEE THIS CALL)
mumps_par%JOB = 6

call MUMPS_exec(mumps_par)

call check_mumps_status(mumps_par, 'elliptic_workers')

!DEALLOCATE STRUCTURES USED BY WORKERS DURING SOLVE
mumps_par%JOB = -2

call MUMPS_exec(mumps_par)

end subroutine elliptic_workers

subroutine check_mumps_status(p, name)
!! check if Mumps error occurred

type(MUMPS_STRUC), intent(in) :: p
character(*), intent(in) :: name

if (p%info(1) < 0 .or. p%infog(1) < 0) then
  write(stderr, *) 'Gemini:PDEelliptic:' // name // '  MUMPS ERROR: details:'
  if (p%info(1) == -1) write(stderr,'(a,i4)') 'the error was reported by processor #',p%info(2)
  write(stderr, *) 'Mumps Error: info(1,2,8):', p%info(1:2), p%info(8)
  write(stderr, *) 'Mumps Error: infoG(1,2)', p%infoG(1:2)
  write(stderr, *) 'for error number meaning, see "8 Error Diagnostics" of MUMPS manual'
  error stop
endif

end subroutine check_mumps_status

end module PDEelliptic

max_stars_repo_name: jklenzing/gemini

max_issues_repo_name: jklenzing/gemini

max_forks_repo_name: jklenzing/gemini


text:
The US Constitution requires a census of all people inside the United States to be taken every ten years in order determine a states representation in the US House of Representatives. These days, the census has been expanded in scope to collect other demographic data, like birthday, race, home ownership, and even your phone number (they say they need it to contact you if they have any questions about your response). In prior years, a small number of people were sent a long form census, which asked substantially more detailed questions, including some very personal details that are quite invasive. This long form was abolished after the 2000 census and replaced by the American Community Survey, which asks the same kinds of questions as the old long form, but is sent out continuously rather than every ten years.

Does anyone know what happens if you dont include your birthdate and telephone number?  Will you get a visit because your form is incomplete?  (Surely they cant require that you have a phone number, especially since the homeless are to be counted, too).
  Residences and nonresidence people are two completely different census efforts (although telephone numbers no longer correspond to a fixed address as of the last census, so there are even more questions about that requirement).  Regarding the homeless, they note that in 2000, they did a tally at shelters on a specific night, soup kitchens during the next day and street locations the following night and the numbers are officially counted under Other noninstitutionalized group quarters, a term whose length to vagueness ratio seems about right.  The form notes that people in prison, nursing homes, armed forces and other institutional locations  including college  on April 1 should not be included on the standard form.  I wonder how the dorms are handled... anybody know?

The data collected are used by Congress to analyze the impacts of certain legislation as well as to determine funding for certain programs. Many people are uncomfortable with the questions that are asked. The US Census Bureau insists that the individually identifiable data they collect is confidential for 72 years. They said the same thing back in the 1940s, when http://www.csmonitor.com/Commentary/Opinion/2010/0324/The2010CensusWillyouranswersstayprivate census data was used to round up JapaneseAmericans to send them to internment camps. More recently, demographic information has been used by Homeland Security to look for terrorists. Seriously. Also, since the dawn of the internet age, http://www.consumeraffairs.com/news04/2007/03/census_breach.html data https://www.census.gov/PressRelease/www/releases/archives/miscellaneous/007497.html breaches have become increasingly common. On the other hand, census information is used to fund programs that assist http://ui23.gamespot.com/2614/animalfarm_2.gif some historically oppressed minorities.

The US Census Bureau has a http://2010.census.gov/2010census/take10map/ website you can use to track Davis participation in the 2010 census. Federal law requires everyone over the age of 18 to participate in the census. The Census Bureau sends people out to homes that do not reply or provide incomplete information. Those who do not participate or knowingly provide false information are subject to fines.

 Davis effort

Davis is part of the http://www.census.gov/regions/seattle/ Seattle Region of the US Census, which includes Northern California, but not the rest of the state.  The nearest local office appears to be in Sacramento on I Street, 9164316020.  Interestingly, they dont list the exact address of the offices.

The local effort to get Davisites to fill out their census forms is called Davis Counts (get it?!) and is being spearheaded by Janice and Adam Bridge.  Janice is quoted in the Davis Enterprise as saying, We tell people its 10 minutes, 10 questions and youre done.  Davis residents who have questions or need assistance with filling out forms can contact the Bridges at mailto(DavisCounts2010 AT gmail DOT com) or 5307536802.  There will also be census booths at the Farmers Market and the Davis Senior Center.  The goal is to ensure that Davis gets its fair share of the federal aid that is distributed to state and local governments.

Volunteer liaisons will be assisting paid employees to try to get a complete and accurate count of residents, including students, the homeless, and those living in shelters.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search