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

      USE VARIABLES
      USE TAVAR

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'GLBVAR.INC'

      REAL              XPF_Range
      LOGICAL                                       RangeFitYN
      INTEGER           IPF_Lo,                     IPF_Hi
      INTEGER           NumPeakFitRange,            CurrentRange
      INTEGER           IPF_Range
      INTEGER           NumInPFR
      REAL              XPF_Pos,                    YPF_Pos
      INTEGER           IPF_RPt
      REAL              XPeakFit,                   YPeakFit
      REAL              PF_FWHM,                    PF_IntBreadth
      COMMON /PEAKFIT1/ XPF_Range(2,MAX_NPFR),      RangeFitYN(MAX_NPFR),        &
                        IPF_Lo(MAX_NPFR),           IPF_Hi(MAX_NPFR),            &
                        NumPeakFitRange,            CurrentRange,                &
                        IPF_Range(MAX_NPFR),                                     &
                        NumInPFR(MAX_NPFR),                                      &
                        XPF_Pos(MAX_NPPR,MAX_NPFR), YPF_Pos(MAX_NPPR,MAX_NPFR),  &
                        IPF_RPt(MAX_NPFR),                                       &
                        XPeakFit(MAX_FITPT),        YPeakFit(MAX_FITPT),         &
                        PF_FWHM(MAX_NPFR),          PF_IntBreadth(MAX_NPFR)

      LOGICAL         in_batch
      COMMON /BATEXE/ in_batch

      LOGICAL, EXTERNAL :: PlotBackground

      IF ( in_batch ) RETURN
!   Setup hardcopy options
      IF (IPTYPE .LT. 0) THEN
        CALL IGrInit('HP')
        CALL IGrHardCopyOptions(1,700)
        CALL IGrHardCopyOptions(2,375)
        CALL IGrHardCopy(' ')
      ENDIF
      CALL Plot_Initialise
      CALL Plot_Panel
      CALL Plot_Custom_Axes
      CALL IPgBorder
      IF (.NOT. NoData) THEN
! Observed profile
        SELECT CASE (ABS(IPTYPE))
          CASE (1)
            CALL Plot_Observed_Profile
          CASE (2)
            CALL Plot_ObsCalc_Profile
        END SELECT
        IF (.NOT. PastPawley) THEN
! Plot peaks found
!          CALL PlotPeaksFound
! Plot peakfit ranges
          IF (NumPeakFitRange .GT. 0) CALL Plot_PeakFit_Info
        ENDIF
        IF ((.NOT. PastPawley) .OR. (iRietveldMethod .NE. INTERNAL_RB)) THEN
! Plot Background
          IF (PlotBackground()) CALL Plot_Background
        ENDIF
!  Plot tic marks etc. if appropriate
        CALL Plot_Calculated_Tics
!   Switch off hardcopy
      ENDIF
      IF (IPTYPE .LT. 0) THEN
        CALL IGrHardCopy('S')
        CALL IGrInit('P')
      ENDIF

      END SUBROUTINE Profile_Plot
!
!*****************************************************************************
!
      SUBROUTINE Plot_Initialise

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'Poly_Colours.inc'

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      REAL            XPG1, XPG2, YPG1, YPG2
      COMMON /PLTINI/ XPG1, XPG2, YPG1, YPG2

      CALL IGrSelect(1,0)
      CALL IGrArea(0.0,0.0,1.0,1.0)
      CALL IGrUnits(0.0,0.0,1.0,1.0)
      CALL IGrAreaClear
      CALL IGrCharSpacing('P') ! Proportional
      CALL IGrCharFont(3)
      CALL IGrColourN(KolNumMain)
      CALL IPgScaling('LIN','LIN')
! Draw axes and add scales
      CALL IPgArea(XPG1,YPG1,XPG2,YPG2) ! In IGrUnits
      CALL IPgUnits(xpgmin, ypgmin, xpgmax, ypgmax)
      CALL IPgClipRectangle('P')
      CALL IPgBorder

      END SUBROUTINE Plot_Initialise
!
!*****************************************************************************
!
      SUBROUTINE Plot_Calculated_Tics

      USE WINTERACTER
      USE REFVAR

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'Poly_Colours.inc'

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      REAL    YPGDIF, YTIC1, YTIC2, xgtem, ygtem
      INTEGER II

      IF (NumOfRef .EQ. 0) RETURN
      CALL IGrColourN(KolNumCTic)
      YPGDIF = (YPGMAX-YPGMIN)
      YTIC1 = YPGMIN + 0.94 * YPGDIF
      YTIC2 = YPGMIN + 0.97 * YPGDIF

      !@@ Replace with binary search

      DO II = 1, NumOfRef
        IF (RefArgK(II) .GE. XPGMIN .AND. RefArgK(II) .LE. XPGMAX) THEN
          CALL IPgUnitsToGrUnits(RefArgK(II),ytic1,xgtem,ygtem)
          CALL IGrMoveTo(xgtem,ygtem)
          CALL IPgUnitsToGrUnits(RefArgK(II),ytic2,xgtem,ygtem)
          CALL IGrLineTo(xgtem,ygtem)
        ENDIF
      ENDDO
      CALL IGrColourN(KolNumMain)

      END SUBROUTINE Plot_Calculated_Tics
!
!*****************************************************************************
!
      SUBROUTINE Plot_Panel

      USE WINTERACTER

      INCLUDE 'Poly_Colours.inc'

      REAL            XPG1, XPG2, YPG1, YPG2
      COMMON /PLTINI/ XPG1, XPG2, YPG1, YPG2

      CALL IGrPaletteRGB(100,253,253,245)
      CALL IGrPaletteRGB(101,250,250,235)
      CALL IGrFillPattern(4,1,1)
      CALL IGrColourN(KolNumPanelOuter)
      CALL IGrRectangle(0.0,0.0,1.0,1.0)
      XD = 0.01
      YD = 0.02
      XT1 = XPG1 - XD
      XT2 = XPG2 + XD
      YT1 = YPG1 - YD
      YT2 = YPG2 + YD
      CALL IGrColourN(KolNumPanelVDark)
      CALL IGrRectangle(XT1,YPG2,XT2,YT2)
      CALL IGrColourN(KolNumPanelDark)
      CALL IGrTriangle(XT1,YT1,XPG1,YPG1,XT1,YPG1)
      CALL IGrRectangle(XT1,YPG1,XPG1,YPG2)
      CALL IGrTriangle(XPG1,YPG2,XT1,YPG2,XT1,YT2)
      CALL IGrColourN(KolNumPanelVLite)
      CALL IGrTriangle(XT1,YT1,XPG1,YT1,XPG1,YPG1)
      CALL IGrRectangle(XPG1,YT1,XT2,YPG1)
      CALL IGrColourN(KolNumPanelLite)
      CALL IGrTriangle(XPG2,YPG2,XT2,YPG2,XT2,YT2)
      CALL IGrTriangle(XPG2,YPG1,XT2,YPG1,XT2,YT1)
      CALL IGrRectangle(XPG2,YPG1,XT2,YPG2)
      CALL IGrColourN(KolNumPGWindow)
      CALL IGrRectangle(XPG1,YPG1,XPG2,YPG2)

      END SUBROUTINE Plot_Panel
!
!*****************************************************************************
!
      SUBROUTINE Plot_Custom_Axes

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'Poly_Colours.inc'

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      REAL xggt, yggt

      CALL IGrColourN(KolNumMain)
      CALL IGrCharSize(1.,1.)
      CALL IPgXScalePos(  0.38)
      CALL IPgXScale('TN')
      CALL IPgXScaleTop('T')
      CALL IGrColourN(KolNumMain)
! Plot y=0 for tidiness
      IF ((ypgmin.LT.0.0) .AND. (ypgmax.GT.0.0)) THEN
        CALL IPgUnitsToGrUnits(xpgmin,0.0,xggt,yggt)
        CALL IGrMoveTo(xggt,yggt)
        CALL IPgUnitsToGrUnits(xpgmax,0.0,xggt,yggt)
        CALL IGrLineTo(xggt,yggt)
      ENDIF
      CALL IGrCharSize(1.,1.2)
      CALL IPgYScaleLeft('TN')
      CALL IPgYScaleRight('T')
      CALL IGrCharSize(1.,1.2)
      IF (XPGMAX .LT. 200.0) THEN
        CALL IPgXLabel('2 theta','C')
      ELSE
        CALL IPgXLabel('time-of-flight (microseconds)','C')
      ENDIF

      ENDSUBROUTINE Plot_Custom_Axes
!
!*****************************************************************************
!
      SUBROUTINE Plot_Background

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'Poly_Colours.inc'

      INTEGER          NBIN, LBIN
      REAL                         XBIN,       YOBIN,       YCBIN,       YBBIN,       EBIN,       AVGESD
      COMMON /PROFBIN/ NBIN, LBIN, XBIN(MOBS), YOBIN(MOBS), YCBIN(MOBS), YBBIN(MOBS), EBIN(MOBS), AVGESD

      INTEGER          IPMIN, IPMAX, iStart, iStop, nPoints
      COMMON /PROFIPM/ IPMIN, IPMAX, iStart, iStop, nPoints

      CALL IPgNewPlot(PgPolyLine,1,nPoints)
      CALL IPgStyle(1,0,0,0,KolNumBack,0)
      CALL IPgXYPairs(XBIN(iStart:),YBBIN(iStart:))

      END SUBROUTINE Plot_Background
!
!*****************************************************************************
!
      SUBROUTINE Plot_Observed_Profile

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'GLBVAR.INC'
      INCLUDE 'Poly_Colours.inc'

      INTEGER          NBIN, LBIN
      REAL                         XBIN,       YOBIN,       YCBIN,       YBBIN,       EBIN,       AVGESD
      COMMON /PROFBIN/ NBIN, LBIN, XBIN(MOBS), YOBIN(MOBS), YCBIN(MOBS), YBBIN(MOBS), EBIN(MOBS), AVGESD

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      INTEGER          IPMIN, IPMAX, iStart, iStop, nPoints
      COMMON /PROFIPM/ IPMIN, IPMAX, iStart, iStop, nPoints

      LOGICAL, EXTERNAL :: PlotObservedErrorBars, ConnectPointsObs
      INTEGER I
      REAL sizmtem, xtem, ytem, xgtem, ygtem

      CALL IGrColourN(KolNumMain)
      CALL IPgYLabelLeft('Observed profile','C9')
! Do the error bars - we've precalculated the min & max pointers
      CALL IGrColourN(KolNumObs)
      IF ( PlotObservedErrorBars() ) THEN
        DO I = IPMIN, IPMAX
          xtem = XBIN(I)
          ytem = MAX(YOBIN(I)-EBIN(I), ypgmin)
          ytem = MIN(ytem, ypgmax)
          CALL IPgUnitsToGrUnits(xtem, ytem, xgtem, ygtem)
          CALL IGrMoveTo(xgtem,ygtem)
          ytem = MIN(YOBIN(I)+EBIN(I), ypgmax)
          ytem = MAX(ytem, ypgmin)
          CALL IPgUnitsToGrUnits(xtem, ytem, xgtem, ygtem)
          CALL IGrLineTo(xgtem,ygtem)
        ENDDO
      ENDIF
      IF (ConnectPointsObs()) THEN
        CALL IPgNewPlot(PgPolyLine,   1,nPoints)
      ELSE
        CALL IPgNewPlot(PgScatterPlot,1,nPoints)
      ENDIF
      IF (ConnectPointsObs()) THEN
        CALL IPgStyle(1,14,3,0,KolNumObs,KolNumObs)
      ELSE
        CALL IPgStyle(1,14,3,0,0,KolNumObs)
      ENDIF
! 13 specifies a square
      CALL IPgMarker(1, 13)
      sizmtem = marker_size*FLOAT(500)/FLOAT(IPMAX-IPMIN)
      sizmtem = MIN(marker_size,sizmtem)
      CALL IGrCharSize(sizmtem,sizmtem)
      IF (ConnectPointsObs()) THEN
        CALL IPgXYPairs(XBIN(iStart:),YOBIN(iStart:))
      ELSE
        CALL IPgScatterPlot(XBIN(iStart:),YOBIN(iStart:))
      ENDIF
      CALL IGrColourN(KolNumMain)

      ENDSUBROUTINE Plot_Observed_Profile
!
!*****************************************************************************
!
      SUBROUTINE Plot_ObsCalc_Profile

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'GLBVAR.INC'
      INCLUDE 'Poly_Colours.inc'

      INTEGER          NBIN, LBIN
      REAL                         XBIN,       YOBIN,       YCBIN,       YBBIN,       EBIN,       AVGESD
      COMMON /PROFBIN/ NBIN, LBIN, XBIN(MOBS), YOBIN(MOBS), YCBIN(MOBS), YBBIN(MOBS), EBIN(MOBS), AVGESD

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      INTEGER          IPMIN, IPMAX, iStart, iStop, nPoints
      COMMON /PROFIPM/ IPMIN, IPMAX, iStart, iStop, nPoints

      REAL             PAWLEYCHISQ, RWPOBS, RWPEXP
      COMMON /PRCHISQ/ PAWLEYCHISQ, RWPOBS, RWPEXP

      REAL            CummChiSqd
      COMMON /CMN007/ CummChiSqd(MOBS)

      LOGICAL, EXTERNAL :: PlotObservedErrorBars, PlotDifferenceErrorBars
      LOGICAL, EXTERNAL :: ConnectPointsObs, Get_ShowCumChiSqd, Get_DivideByEsd
      REAL, EXTERNAL :: PlotEsdMultiplier
      REAL    YDIF(MOBS), YADD
      INTEGER I, II
      REAL    sizmtem, xptem, yptem, xgtem, ygtem, esdmul
      LOGICAL tGet_ShowCumChiSqd, tGet_DivideByEsd

      tGet_ShowCumChiSqd = Get_ShowCumChiSqd()
      tGet_DivideByEsd = Get_DivideByEsd()
      CALL IGrColourN(KolNumMain)
      CALL IPgYLabelLeft('Observed profile','C9')
! The y-values of the difference profile.
      YADD = 0.5*(YPGMAX+YPGMIN)
      IF (tGet_DivideByEsd) THEN
        DO II = iStart, iStop
          YDIF(II) = YADD + (YOBIN(II) - YCBIN(II))*AVGESD/EBIN(II)
        ENDDO
      ELSE
        DO II = iStart, iStop
          YDIF(II) = YADD + YOBIN(II) - YCBIN(II)
        ENDDO
      ENDIF
      IF (tGet_ShowCumChiSqd) THEN
        CALL IPgNewPlot(PgPolyLine, 4, nPoints)
      ELSE
        CALL IPgNewPlot(PgPolyLine, 3, nPoints)
      ENDIF
      CALL IPgStyle(2, 0, 0, 0, KolNumDif, 0)
! Q & D hack
      IF (ConnectPointsObs()) THEN
        CALL IPgStyle(1, 0, 3, 0, KolNumObs, KolNumObs)
      ELSE
        CALL IPgStyle(1, 0, 3, 0, 0, KolNumObs)
      ENDIF
! Calculated
      CALL IPgStyle(3, 0, 0, 0, KolNumCal, 0)
! Cumulative profile chi-squared
      IF (tGet_ShowCumChiSqd) CALL IPgStyle(4, 0, 0, 0, KolNumMTic, 0)
! The following four lines set the markers for the observed profile.
      CALL IPgMarker( 2, 13)
      sizmtem = marker_size*FLOAT(500)/FLOAT(IPMAX-IPMIN)
      sizmtem = MIN(marker_size, sizmtem)
      CALL IGrCharSize(sizmtem, sizmtem)
! Draw the observed profile. Markers can still be used. Consecutive data points are joined
! by lines. These can be straight or splines
      CALL IPgXYPairs(XBIN(iStart:), YOBIN(iStart:))
! Now draw the difference plofile
      CALL IPgXYPairs(XBIN(iStart:), YDIF(iStart:))
! Do the error bars on the difference profile - we've precalculated the min & max pointers
      IF (PlotDifferenceErrorBars()) THEN
        esdmul = PlotEsdMultiplier()
        CALL IGrColourN(KolNumDif)
        DO I = IPMIN, IPMAX
          xptem = XBIN(I)
          yptem = MAX(YDIF(I) - (EBIN(I) * esdmul), ypgmin)
          yptem = MIN(yptem,ypgmax)
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrMoveTo(xgtem,ygtem)
          yptem = MIN(YDIF(I) + (EBIN(I) * esdmul), ypgmax)
          yptem = MAX(yptem, ypgmin)
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrLineTo(xgtem, ygtem)
        ENDDO
      ENDIF
! Do the error bars on the observed profile - we've precalculated the min & max pointers
      CALL IGrColourN(KolNumObs)
      IF (PlotObservedErrorBars()) THEN
        DO I = IPMIN, IPMAX
          xptem = XBIN(I)
          yptem = MAX(YOBIN(I) - ( EBIN(I)  * esdmul ), ypgmin)
          yptem = MIN(yptem,ypgmax)
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrMoveTo(xgtem,ygtem)
          yptem = MIN(YOBIN(I) + ( EBIN(I)  * esdmul ), ypgmax)
          yptem = MAX(yptem, ypgmin)
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrLineTo(xgtem, ygtem)
        ENDDO
      ENDIF
      CALL IPgXYPairs(XBIN(iStart:), YCBIN(iStart:))
      IF (tGet_ShowCumChiSqd) CALL IPgXYPairs(XBIN(iStart:), CummChiSqd(iStart:))
      CALL IGrCharSize(1.0, 1.0)
      CALL IGrColourN(KolNumMain)

      END SUBROUTINE Plot_ObsCalc_Profile
!
!*****************************************************************************
!
      SUBROUTINE Plot_PeakFit_Info
!
! Plots all the information about the Peak Fitting Option
! Highlight (recolour) the peak fit range and label the peaks.
! If already fitted then show the fitted profile as well.
!
      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'GLBVAR.INC'
      INCLUDE 'Poly_Colours.inc'

      INTEGER          NBIN, LBIN
      REAL                         XBIN,       YOBIN,       YCBIN,       YBBIN,       EBIN,       AVGESD
      COMMON /PROFBIN/ NBIN, LBIN, XBIN(MOBS), YOBIN(MOBS), YCBIN(MOBS), YBBIN(MOBS), EBIN(MOBS), AVGESD

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      INTEGER          IPMIN, IPMAX, iStart, iStop, nPoints
      COMMON /PROFIPM/ IPMIN, IPMAX, iStart, iStop, nPoints

      REAL              XPF_Range
      LOGICAL                                       RangeFitYN
      INTEGER           IPF_Lo,                     IPF_Hi
      INTEGER           NumPeakFitRange,            CurrentRange
      INTEGER           IPF_Range
      INTEGER           NumInPFR
      REAL              XPF_Pos,                    YPF_Pos
      INTEGER           IPF_RPt
      REAL              XPeakFit,                   YPeakFit
      REAL              PF_FWHM,                    PF_IntBreadth
      COMMON /PEAKFIT1/ XPF_Range(2,MAX_NPFR),      RangeFitYN(MAX_NPFR),        &
                        IPF_Lo(MAX_NPFR),           IPF_Hi(MAX_NPFR),            &
                        NumPeakFitRange,            CurrentRange,                &
                        IPF_Range(MAX_NPFR),                                     &
                        NumInPFR(MAX_NPFR),                                      &
                        XPF_Pos(MAX_NPPR,MAX_NPFR), YPF_Pos(MAX_NPPR,MAX_NPFR),  &
                        IPF_RPt(MAX_NPFR),                                       &
                        XPeakFit(MAX_FITPT),        YPeakFit(MAX_FITPT),         &
                        PF_FWHM(MAX_NPFR),          PF_IntBreadth(MAX_NPFR)

      INTEGER        CurrHiLiPFR
      COMMON /HLPFR/ CurrHiLiPFR

      LOGICAL, EXTERNAL :: PlotPeakFitDifferenceProfile
      REAL Difference(1:MAX_FITPT)
      INTEGER JJ, iord_peak, I, ipf1, ipf2, II, ix1, ix2, J
      REAL yt1, yt2, xg1, yg1, yg2, AveESD
      REAL ulpx, lrpx, ulgx, ulgy, lrgx, lrgy
      REAL xgtem, ygtem
      CHARACTER*1 ChrPkNum
      CHARACTER*2 ChrPkNum2

      iord_peak = 0
      CALL IGrFillPattern(Hatched, Medium, DiagUp)
      CALL IGrCharSize(Char_Size, Char_Size)
      DO i = 1, NumPeakFitRange
        IF ( .NOT. (((XPF_Range(1,i) .LT. XPGMIN) .AND. (XPF_Range(2,i) .LT. XPGMIN)) .OR. &
                    ((XPF_Range(1,i) .GT. XPGMAX) .AND. (XPF_Range(2,i) .GT. XPGMAX)))) THEN
          ulpx = MAX(XPF_Range(1,i), XPGMIN)
          ulpx = MIN(ulpx, XPGMAX)
          lrpx = MAX(XPF_Range(2,i), XPGMIN)
          lrpx = MIN(lrpx, XPGMAX)
! Draw the hatched rectangle indicating the area swept out by the user
          CALL IPgUnitsToGrUnits(ulpx, YPGMAX, ulgx, ulgy)
          CALL IPgUnitsToGrUnits(lrpx, YPGMIN, lrgx, lrgy)
          CALL IGrColourN(KolNumPanelDark)
          CALL IGrRectangle(ulgx, ulgy, lrgx, lrgy)
! Then the fitted peak
          ipf1 = IPF_RPt(i) + 1
          ipf2 = IPF_RPt(i+1)
! Now we do a quick check to see if the range has been fitted
          IF (RangeFitYN(i)) THEN
            IF ((XPeakFit(ipf2) .GT. XPGMIN) .AND. (XPeakFit(ipf1) .LT. XPGMAX)) THEN
! We can plot the calculated fit
              DO II = ipf1, ipf2
                IF (XpeakFit(II) .GE. XPGMIN) THEN
! If this two theta is within the drawing area, and the previous wasn't
! then we need to start at the _previous_ point. Unless that point isn't part of this peak, of course.
                  ix1 = MAX(II-1, ipf1)
                  GOTO 110
                ENDIF
              ENDDO
! ix1 is now a pointer into XPeakFit, YPeakFit, pointing to the start of the range
 110          DO II = ipf2, ipf1, -1
                IF (XpeakFit(II) .LE. XPGMAX) THEN
                  ix2 = MIN(II+1, ipf2)
                  GOTO 120
                ENDIF
              ENDDO
! ix2 is now a pointer into XPeakFit, YPeakFit, pointing to the end of the range
 120          CONTINUE
              IF (PlotPeakFitDifferenceProfile()) THEN
! Calculate average ESD
                AveESD = 0.0
                DO JJ = ipf1, ipf2
                   AveESD = AveESD + EBIN(IPF_Lo(i)+JJ-ipf1)
                ENDDO
                AveESD = AveESD / FLOAT(1+ipf2-ipf1)
                DO JJ = ipf1, ipf2
                   Difference(JJ) = (((YOBIN(IPF_Lo(i)+JJ-ipf1) - YPeakFit(JJ)) * 2.50 * AveESD) / EBIN(IPF_Lo(i)+JJ-ipf1)) + 0.5*(YPGMAX+YPGMIN)
!O                   Difference(JJ) = ((YOBIN(IPF_Lo(i)+JJ-ipf1) - YPeakFit(JJ))) + 0.5*(YPGMAX+YPGMIN)
                ENDDO
                CALL IPgNewPlot(PgPolyLine, 2, (1+ix2-ix1) )
                CALL IPgStyle(1, 0, 0, 0, KolNumPeakFit, 0)
                CALL IPgStyle(2, 0, 0, 0, KolNumCal, 0)
                CALL IPgXYPairs(XPeakFit(ix1), YPeakFit(ix1))
                CALL IPgXYPairs(XPeakFit(ix1), Difference(ix1))
              ELSE
                CALL IPgNewPlot(PgPolyLine, 1, (1+ix2-ix1) )
                CALL IPgStyle(1, 0, 0, 0, KolNumPeakFit, 0)
                CALL IPgXYPairs(XPeakFit(ix1), YPeakFit(ix1))
              ENDIF
            ENDIF
          ENDIF
! Label the peaks in this peak fit range with their numbers
          CALL IGrColourN(KolNumPeakPos)
          DO j = 1, NumInPFR(i)
            iord_peak = iord_peak + 1
            IF ((XPF_Pos(j,i) .GT. XPGMIN) .AND. (XPF_Pos(j,i) .LT. XPGMAX)) THEN
              yt1 = MAX(YPGMIN, 0.0)
              yt1 = MIN(yt1, YPGMAX)
              CALL IPgUnitsToGrUnits(XPF_Pos(j,i), yt1, xg1, yg1)
              CALL IGrMoveTo(xg1, yg1)
              yt2 = MAX(YPGMIN, YPF_Pos(j,i))
              yt2 = MIN(yt2, YPGMAX)
              CALL IPgUnitsToGrUnits(XPF_Pos(j,i), yt2, xg1, yg2)
              CALL IGrLineTo(xg1, yg2)
              CALL IPgUnitsToGrUnits(XPF_Pos(j,i), YPF_Pos(j,i), xgtem, ygtem)
              ygtem = MIN(ulgy, ygtem+0.05*ABS(ulgy-lrgy))
              IF ((ygtem .GT. lrgy) .AND. (ygtem .LT. ulgy)) THEN
                IF (iord_peak .LT. 10) THEN
                  CALL IntegerToString(iord_peak, ChrPkNum, '(I1)')
                  CALL IGrCharOut(xgtem, ygtem, ChrPkNum)
                ELSE
                  CALL IntegerToString(iord_peak, ChrPkNum2, '(I2)')
                  CALL IGrCharOut(xgtem, ygtem, ChrPkNum2)
                ENDIF
              ENDIF
            ENDIF
          ENDDO
        ELSE
          iord_peak = iord_peak + NumInPFR(i)
        ENDIF
      ENDDO
      CALL IGrFillPattern(Outline)
      CurrHiLiPFR = 0
      CALL HighLightPFR

      END SUBROUTINE Plot_PeakFit_Info
!
!*****************************************************************************
!
      SUBROUTINE PlotPeaksFound

      USE WINTERACTER

      IMPLICIT NONE

      INCLUDE 'params.inc'
      INCLUDE 'Poly_Colours.inc'

      REAL             XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD
      COMMON /PROFRAN/ XPMIN,     XPMAX,     YPMIN,     YPMAX,       &
                       XPGMIN,    XPGMAX,    YPGMIN,    YPGMAX,      &
                       XPGMINOLD, XPGMAXOLD, YPGMINOLD, YPGMAXOLD

      REAL                PeakFindPos
      INTEGER                                           nPeaksFound
      COMMON / PEAKFIND / PeakFindPos(1:MaxPeaksFound), nPeaksFound

      INTEGER I
      REAL xptem, yptem, xgtem, ygtem

      IF (nPeaksFound .EQ. 0) RETURN
      CALL IGrColourN(KolNumCal)
      DO I = 1, nPeaksFound
        xptem = PeakFindPos(I)
        IF ((xptem .LT. XPGMAX) .AND. (xptem .GT. XPGMIN)) THEN
          yptem = ypgmin
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrMoveTo(xgtem, ygtem)
          yptem = ypgmax
          CALL IPgUnitsToGrUnits(xptem, yptem, xgtem, ygtem)
          CALL IGrLineTo(xgtem, ygtem)
        ENDIF
      ENDDO

      END SUBROUTINE PlotPeaksFound
!
!*****************************************************************************
!

max_stars_repo_name: ccdc-opensource/dash

max_issues_repo_name: ccdc-opensource/dash

max_forks_repo_name: ccdc-opensource/dash


text:
      subroutine eq1()

      INTEGER*4 VAR1, VAR2, VAR3
      COMMON /COMMON1/ VAR1, VAR2, VAR3

      INTEGER*4 VAREQ(1)
      EQUIVALENCE(VAREQ,VAR1)

      VAR2 = 2
      VAR3 = 3
      end

      subroutine eq2()

      INTEGER*4 VAR1, VAR2, VAR3
      COMMON /COMMON2/ VAR1, VAR2, VAR3

      INTEGER*4 VAREQ(2)
      EQUIVALENCE(VAREQ,VAR1)

      VAR2 = 2
      VAR3 = 3
      end

      subroutine eq3()

      INTEGER*4 VAR1, VAR2, VAR3
      COMMON /COMMON3/ VAR1, VAR2, VAR3

      INTEGER*4 VAREQ(3)
      EQUIVALENCE(VAREQ,VAR1)

      VAR2 = 2
      VAR3 = 3
      end

      subroutine eq4()

      INTEGER*4 VAR1, VAR2, VAR3
      COMMON /COMMON4/ VAR1, VAR2, VAR3

      INTEGER*4 VAREQ(2)
      EQUIVALENCE(VAREQ,VAR2)

      VAR2 = 2
      VAR3 = 3
      end

      subroutine eq5()

      INTEGER*4 VAR1, VAR2, VAR3
      COMMON /COMMON5/ VAR1, VAR2, VAR3

      INTEGER*4 VAREQ(3)
      EQUIVALENCE(VAREQ,VAR2)

      VAR2 = 2
      VAR3 = 3
      end

ext: f

max_stars_repo_name: camfort/fortran-vars

max_issues_repo_name: camfort/fortran-vars

max_forks_repo_name: camfort/fortran-vars


    Program zgbbrd_example

!     ZGBBRD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgbbrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: vect = 'N'
!     .. Local Scalars ..
      Integer :: i, info, j, kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), c(:, :), pt(:, :), q(:, :), &
        work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:), rwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZGBBRD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, kl, ku, ncc
      ldab = kl + ku + 1
      ldc = m
      ldpt = n
      ldq = m
      Allocate (ab(ldab,n), c(m,ncc), pt(ldpt,n), q(ldq,m), work(m+n), d(n), &
        e(n-1), rwork(m+n))

!     Read A from data file

      Read (nin, *)((ab(ku+1+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, m)

!     Reduce A to upper bidiagonal form

      Call zgbbrd(vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, ldq, pt, ldpt, &
        c, ldc, work, rwork, info)

!     Print bidiagonal form

      Write (nout, *)
      Write (nout, *) 'Diagonal'
      Write (nout, 100) d(1:min(m,n))
      Write (nout, *) 'Superdiagonal'
      Write (nout, 100) e(1:min(m,n)-1)

100   Format (1X, 8F9.4)
    End Program


! { dg-do run }
!
! Test for pr52413
!

program test_frac

  real :: y
  y=fraction (-2.0)
  if (fraction (-2.0) /= -0.5) STOP 1
  if (fraction (-0.0) /= 0.0) STOP 2
  if (sign(1.0, fraction(-0.0)) /= -1.0) STOP 3
  if (fraction (-2.0_8) /=  -0.5) STOP 4

end program test_frac


text:
!
!   FnVFV.f90
!
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFB(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

cons=gliq+(vals(1)*(qm(inds(1),gil,gim,gih,giW,giAgg,gij+1)*gmort+ql(inds(1),gil,gim,gih,giW,giAgg,gij+1)*gloc)+(vals(2)*(qm(inds(2),gil,gim,gih,giW,giAgg,gij+1)*gmort+ql(inds(2),gil,gim,gih,giW,giAgg,gij+1)*gloc)))*ghouse-FnQb(bsav,0.0d0)*bsav

if(cons .GT. cmin) then

FnVFB = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*EVown(inds(1),gil,gim,gih,giW,giAgg,gij)+vals(2)*EVown(inds(2),gil,gim,gih,giW,giAgg,gij)))

else

FnVFB = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFB

max_stars_repo_name: lnsongxf/housing-boom-bust

max_issues_repo_name: floswald/housing-boom-bust

max_forks_repo_name: kurtmitman/housing-boom-bust


text:
! SPDX-Identifier: MIT

!> Version information on stdlib
module stdlib_version
    implicit none
    private

    public :: get_stdlib_version
    public :: stdlib_version_string, stdlib_version_compact

    !> String representation of the standard library version
    character(len=*), parameter :: stdlib_version_string = "0.1.0"

    !> Major version number of the above standard library version
    integer, parameter :: stdlib_major = 0

    !> Minor version number of the above standard library version
    integer, parameter :: stdlib_minor = 1

    !> Patch version number of the above standard library version
    integer, parameter :: stdlib_patch = 0

    !> Compact numeric representation of the standard library version
    integer, parameter :: stdlib_version_compact = &
        & stdlib_major*10000 + stdlib_minor*100 + stdlib_patch

contains

!> Getter function to retrieve standard library version
pure subroutine get_stdlib_version(major, minor, patch, string)

    !> Major version number of the standard library version
    integer, intent(out), optional :: major

    !> Minor version number of the standard library version
    integer, intent(out), optional :: minor

    !> Patch version number of the standard library version
    integer, intent(out), optional :: patch

    !> String representation of the standard library version
    character(len=:), allocatable, intent(out), optional :: string

    if (present(major)) then
        major = stdlib_major
    end if
    if (present(minor)) then
        minor = stdlib_minor
    end if
    if (present(patch)) then
        patch = stdlib_patch
    end if
    if (present(string)) then
        string = stdlib_version_string
    end if

end subroutine get_stdlib_version

end module stdlib_version

max_stars_repo_name: zoziha/dp-stdlib

max_issues_repo_name: zoziha/dp-stdlib

max_forks_repo_name: zoziha/dp-stdlib


text:
! { dg-do run }
! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF.
! Patch derived from PR, submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
program gfcbug61
  implicit none
  integer, parameter :: nmlunit = 12    ! Namelist unit
  integer            :: stat

  open (nmlunit, status="scratch")
  write(nmlunit, '(a)') "&REPORT type='report1' /"
  write(nmlunit, '(a)') "&REPORT type='report2' /"
  write(nmlunit, '(a)') "!"
  rewind (nmlunit)

! The call to position_nml is contained in the subroutine
  call read_report (nmlunit, stat)
  rewind (nmlunit)
  call position_nml (nmlunit, 'MISSING', stat)
  rewind (nmlunit)
  call read_report (nmlunit, stat)              ! gfortran fails here

contains

  subroutine position_nml (unit, name, status)
    ! Check for presence of namelist 'name'
    integer                      :: unit, status
    character(len=*), intent(in) :: name

    character(len=255) :: line
    integer            :: ios, idx, k
    logical            :: first

    first = .true.
    status = 0
    do k=1,25
       line = ""
       read (unit,'(a)',iostat=ios) line
       if (ios < 0) then
          ! EOF encountered!
          backspace (unit)
          status = -1
          return
       else if (ios > 0) then
          ! Error encountered!
          status = +1
          return
       end if
       idx = index (line, "&"//trim (name))
       if (idx > 0) then
          backspace (unit)
          return
       end if
    end do
    if (k.gt.10) call abort
  end subroutine position_nml

  subroutine read_report (unit, status)
    integer :: unit, status

    integer            :: iuse, ios, k
    !------------------
    ! Namelist 'REPORT'
    !------------------
    character(len=12) :: type
    namelist /REPORT/ type
    !-------------------------------------
    ! Loop to read namelist multiple times
    !-------------------------------------
    iuse = 0
    do k=1,25
       !----------------------------------------
       ! Preset namelist variables with defaults
       !----------------------------------------
       type      = ''
       !--------------
       ! Read namelist
       !--------------
       call position_nml (unit, "REPORT", status)
       if (stat /= 0) then
          ios = status
          if (iuse /= 2) call abort()
          return
       end if
       read (unit, nml=REPORT, iostat=ios)
       if (ios /= 0) exit
       iuse = iuse + 1
    end do
    if (k.gt.10) call abort
    status = ios
  end subroutine read_report

end program gfcbug61

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program COSMOS_development

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   COSMOS_development - a program that only needs minor customization to read
!      in a text-based, whitespace-separated dataset.
!
!     original 3 May       2012   Tim Hoar       NCAR/IMAGe
!     modified 6 September 2012   Rafael Rosolem University of Arizona
!     modified 10 October  2012   Tim Hoar
!        * include site-specific metadata in obs sequence
!
! QC flags are defined as: 0 = BEST     (corrected for water vapor)
!                          1 = OK       (NOT corrected for water vapor)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

use          types_mod, only : r8, MISSING_R8, metadatalength

use      utilities_mod, only : initialize_utilities, finalize_utilities, &
                               register_module, error_handler, E_MSG, E_ERR, &
                               open_file, close_file, do_nml_file, do_nml_term, &
                               check_namelist_read, find_namelist_in_file, &
                               nmlfileunit, file_exist, to_upper, find_textfile_dims

use  netcdf_utilities_mod, only : nc_check

use   time_manager_mod, only : time_type, set_calendar_type, GREGORIAN, &
                               set_date, set_time, get_time, print_time, &
                               print_date, operator(-), operator(+), operator(>), &
                               operator(<), operator(==), operator(<=), operator(>=)

use       location_mod, only : location_type, set_location, VERTISSURFACE

use   obs_sequence_mod, only : obs_sequence_type, obs_type, read_obs_seq, &
                               static_init_obs_sequence, init_obs, write_obs_seq, &
                               init_obs_sequence, get_num_obs, set_obs_def, &
                               set_copy_meta_data, set_qc_meta_data, &
                               set_obs_values, set_qc

use        obs_def_mod, only : obs_def_type, set_obs_def_type_of_obs, &
                               set_obs_def_location, set_obs_def_time, &
                               set_obs_def_error_variance, set_obs_def_key

use  obs_utilities_mod, only : add_obs_to_seq

use obs_def_COSMOS_mod, only : set_cosmos_metadata

use       obs_kind_mod, only : COSMOS_NEUTRON_INTENSITY

use typesizes
use netcdf

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

!-----------------------------------------------------------------------
! Namelist with default values
!-----------------------------------------------------------------------

character(len=256) :: site_metadata_file = 'COSMIC_parlist.nc'
character(len=128) :: text_input_file = 'textdata.input'
character(len=128) :: obs_out_file    = 'obs_seq.out'
character(len=128) :: sitename        = 'missing'
integer            :: year            = -1
real(r8)           :: maxgoodqc       = 3.0_r8
logical            :: verbose         = .false.

namelist /COSMOS_development_nml/ site_metadata_file, text_input_file, &
   obs_out_file, sitename, year, maxgoodqc, verbose

!-----------------------------------------------------------------------
! globally-scoped variables
!-----------------------------------------------------------------------

character(len=256)      :: input_line, string1, string2, string3
integer                 :: iline
logical                 :: first_obs
integer                 :: oday, osec, rcio, iunit
integer                 :: num_copies, num_qc, max_obs
real(r8)                :: oerr, qc
type(obs_sequence_type) :: obs_seq
type(obs_type)          :: obs, prev_obs
type(time_type)         :: prev_time

! The cosmosdata type holds all the information from the text file
! from the COSMOS instrument. This file format is known best to Rafael.
! The files using this format are not generally available to the public.

type cosmosdata
  type(time_type)   :: time_obs
  character(len=20) :: monthstring = 'month'
  character(len=20) :: daystring   = 'day'
  character(len=20) :: hourstring  = 'hour'
  character(len=20) :: doystring   = 'doy'
  character(len=20) :: neutronstring    = 'neutron_fluxAVE'
  character(len=20) :: neutronstdstring = 'neutron_fluxSTD'
  character(len=20) :: neutronQCstring  = 'neutron_fluxQC'
  integer  :: monthindex
  integer  :: dayindex
  integer  :: hourindex
  integer  :: doyindex
  integer  :: neutronindex
  integer  :: neutronstdindex
  integer  :: neutronQCindex
  integer  :: month
  integer  :: day
  real(r8) :: hour
  real(r8) :: doy
  real(r8) :: neutron
  real(r8) :: neutronstd
  integer  :: neutronQC
end type cosmosdata

type(cosmosdata) :: cosmos ! we only need one of these.

! The site_metadata type holds all the site-specific information

type site_metadata
   character(len=metadatalength) :: sitename
   type(location_type) :: location
   real(r8)            :: latitude
   real(r8)            :: longitude
   real(r8)            :: elevation
   real(r8)            :: bd         ! Dry Soil Bulk Density [  g / cm^3]
   real(r8)            :: lattwat    ! Lattice Water Content [M^3 /  M^3]
   real(r8)            :: N          ! High Energy Neutron Intensity
   real(r8)            :: alpha      ! Ratio of Fast Neutron Creation Factor
   real(r8)            :: L1         ! High Energy   Soil Attenuation Length
   real(r8)            :: L2         ! High Energy  Water Attenuation Length
   real(r8)            :: L3         ! Fast Neutron  Soil Attenuation Length
   real(r8)            :: L4         ! Fast Neutron Water Attenuation Length
end type site_metadata

type(site_metadata), allocatable, dimension(:) :: cosmos_metadata
integer  :: nSites, siteIndx, obsindx
real(r8) :: bd, lattwat, N, alpha, L1, L2, L3, L4

!-----------------------------------------------------------------------
! start of executable code
!-----------------------------------------------------------------------

call initialize_utilities('COSMOS_development')

! Print module information to log file and stdout.
call register_module(source, revision, revdate)

! Read the namelist entry
call find_namelist_in_file("input.nml", "COSMOS_development_nml", iunit)
read(iunit, nml = COSMOS_development_nml, iostat = rcio)
call check_namelist_read(iunit, rcio, "COSMOS_development_nml")

! Record the namelist values used for the run ...
if (do_nml_file()) write(nmlfileunit, nml=COSMOS_development_nml)
if (do_nml_term()) write(     *     , nml=COSMOS_development_nml)

! time setup
call set_calendar_type(GREGORIAN)
prev_time = set_time(0, 0)

! Read the COSMOS metadata/parameters for each site.
! These will be added to the metadata for neutron intensity observations.
nSites   = read_cosmos_metadata(site_metadata_file)
siteIndx = find_site_index(sitename)
bd       = cosmos_metadata(siteIndx)%bd
lattwat  = cosmos_metadata(siteIndx)%lattwat
N        = cosmos_metadata(siteIndx)%N
alpha    = cosmos_metadata(siteIndx)%alpha
L1       = cosmos_metadata(siteIndx)%L1
L2       = cosmos_metadata(siteIndx)%L2
L3       = cosmos_metadata(siteIndx)%L3
L4       = cosmos_metadata(siteIndx)%L4

if (verbose) print *, 'COSMOS site located at lat, lon, elev  =', &
                       cosmos_metadata(siteIndx)%latitude, &
                       cosmos_metadata(siteIndx)%longitude, &
                       cosmos_metadata(siteIndx)%elevation

! We need to know the maximum number of observations in the input file.
! Each line has info for a single observation we want (COSMOS neutron counts).
! Each observation in this series will have a single
! observation value, its standard deviation, and a quality control flag.
! Initialize two empty observations - one to track location
! in observation sequence - the other is for the new observation.

call find_textfile_dims(text_input_file, max_obs)

iunit = open_file(text_input_file, 'formatted', 'read')
if (verbose) print *, 'opened input file ' // trim(text_input_file)

num_copies = 1
num_qc     = 1
first_obs  = .true.

call static_init_obs_sequence()
call init_obs(        obs,      num_copies, num_qc)
call init_obs(        prev_obs, num_copies, num_qc)
call init_obs_sequence(obs_seq, num_copies, num_qc, max_obs)

! the first one needs to contain the string 'observation' and the
! second needs the string 'QC'.
call set_copy_meta_data(obs_seq, 1, 'observation')
call set_qc_meta_data(  obs_seq, 1, 'COSMOS QC')

! The first line describes all the fields ... column headers, if you will
call decode_header(iunit)

obsloop: do iline = 2,max_obs

   ! read in entire text line into a buffer
   read(iunit,'(A)',iostat=rcio) input_line
   if (rcio < 0) exit obsloop
   if (rcio > 0) then
      write (string1,'(''Cannot read (error '',i3,'') line '',i8,'' in '',A)') &
                    rcio, iline, trim(text_input_file)
      call error_handler(E_ERR,'main', string1, source, revision, revdate)
   endif

   ! parse the line into the cosmos structure (including the observation time)
   call stringparse(input_line, iline)

   if (iline <= 2) then
      write(*,*)''
      write(*,*)'Check of the first observation: (column,string,value)'
      write(*,*)cosmos%monthindex      , cosmos%monthstring       , cosmos%month
      write(*,*)cosmos%dayindex        , cosmos%daystring         , cosmos%day
      write(*,*)cosmos%hourindex       , cosmos%hourstring        , cosmos%hour
      write(*,*)cosmos%doyindex        , cosmos%doystring         , cosmos%doy
      write(*,*)cosmos%neutronindex    , cosmos%neutronstring     , cosmos%neutron
      write(*,*)cosmos%neutronstdindex , cosmos%neutronstdstring  , cosmos%neutronstd
      write(*,*)cosmos%neutronQCindex  , cosmos%neutronQCstring   , cosmos%neutronQC
      call print_date(cosmos%time_obs, 'observation date is')
      call print_time(cosmos%time_obs, 'observation time is')
   end if

   if (verbose) call print_date(cosmos%time_obs, 'obs time is')

   call get_time(cosmos%time_obs, osec, oday)

   ! make an obs derived type, and then add it to the sequence
   ! If the QC value is good, use the observation.
   ! Increasingly larger QC values are more questionable quality data.
   ! Quality Control Flags by Rafael Rosolem (rosolem@email.arizona.edu)
   ! QC flags define as: 0 = BEST     (corrected for water vapor)
   !                     1 = OK       (NOT corrected for water vapor)
   !                     2 = BAD      (not reliable/consistent)
   !                     3 = MISSING  (missing data, i.e. -9999)

   if (cosmos%neutronQC <= maxgoodqc) then   ! COSMOS neutron counts
      oerr = cosmos%neutronstd
      qc   = real(cosmos%neutronQC,r8)

      call set_cosmos_metadata(obsindx, bd, lattwat, N, alpha, L1, L2, L3, L4)

      call create_3d_obs(cosmos_metadata(siteIndx)%latitude, &
                         cosmos_metadata(siteIndx)%longitude, 0.0_r8, VERTISSURFACE, &
           cosmos%neutron, COSMOS_NEUTRON_INTENSITY, oerr, oday, osec, qc, obsindx, obs)

      call add_obs_to_seq(obs_seq, obs, cosmos%time_obs, prev_obs, prev_time, first_obs)
   endif

end do obsloop

! if we added any obs to the sequence, write it out to a file now.
if ( get_num_obs(obs_seq) > 0 ) then
   if (verbose) print *, 'writing obs_seq, obs_count = ', get_num_obs(obs_seq)
   call write_obs_seq(obs_seq, obs_out_file)
endif

! end of main program
call finalize_utilities()

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   create_3d_obs - subroutine that is used to create an observation
!                   type from observation data.
!
!   NOTE: assumes the code is using the threed_sphere locations module,
!         that the observation has a single data value and a single
!         qc value.
!
!    lat   - latitude of observation
!    lon   - longitude of observation
!    vval  - vertical coordinate
!    vkind - kind of vertical coordinate (pressure, level, etc)
!    obsv  - observation value
!    okind - observation kind
!    oerr  - observation error
!    day   - gregorian day
!    sec   - gregorian second
!    qc    - quality control value
!    key   - index to metadata in obs_def_COSMOS_mod arrays
!    obs   - observation type
!
!    extended from the observations/utilities/obs_utilities_mod.f90 v 5601
!    to support the extra metadata -- TJH
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine create_3d_obs(lat, lon, vval, vkind, obsv, okind, oerr, day, sec, qc, key, obs)
integer,        intent(in)    :: okind, vkind, day, sec
real(r8),       intent(in)    :: lat, lon, vval, obsv, oerr, qc
integer,        intent(in)    :: key
type(obs_type), intent(inout) :: obs

real(r8)              :: obs_val(1), qc_val(1)
type(obs_def_type)    :: obs_def

call set_obs_def_location(obs_def, set_location(lon, lat, vval, vkind))
call set_obs_def_type_of_obs(obs_def, okind)
call set_obs_def_time(obs_def, set_time(sec, day))
call set_obs_def_error_variance(obs_def, oerr * oerr)
call set_obs_def_key(obs_def, key)
call set_obs_def(obs, obs_def)

obs_val(1) = obsv
call set_obs_values(obs, obs_val)
qc_val(1)  = qc
call set_qc(obs, qc_val)

end subroutine create_3d_obs

subroutine decode_header(iunit)
! Reads the first line of the header and parses the information.
! FIXME ... decode the header ... do not assume ...
integer, intent(in) :: iunit

read(iunit,'(A)',iostat=rcio) input_line
if (rcio /= 0) then
  write(string1,*)'Cannot parse header. Begins <',trim(input_line(1:40)),'>'
  call error_handler(E_ERR,'decode_header',string1, source, revision, revdate)
endif

call error_handler(E_MSG,'decode_header','hardcoding values for now ... dangerous', &
                     source, revision, revdate)

cosmos%monthindex      = 1
cosmos%dayindex        = 2
cosmos%hourindex       = 3
cosmos%doyindex        = 4
cosmos%neutronindex    = 5
cosmos%neutronstdindex = 6
cosmos%neutronQCindex  = 7

end subroutine decode_header

subroutine stringparse(str1,linenum)
! just declare everything as reals and chunk it

character(len=*), intent(in) :: str1
integer         , intent(in) :: linenum

real(r8), dimension(7) :: values
integer :: iday, ihour, imin, isec, seconds

values = MISSING_R8

read(str1,*,iostat=rcio) values
if (rcio /= 0) then
  write(string1,*)'Cannot parse line',linenum,'. Begins <',trim(str1(1:40)),'>'
  call error_handler(E_ERR,'stringparse',string1, source, revision, revdate)
endif

! Stuff what we want into the cosmos structure
!
cosmos%month      = nint(values(cosmos%monthindex     ))
cosmos%day        = nint(values(cosmos%dayindex       ))
cosmos%hour       =      values(cosmos%hourindex       )
cosmos%doy        =      values(cosmos%doyindex        )
cosmos%neutron    =      values(cosmos%neutronindex    )
cosmos%neutronstd =      values(cosmos%neutronstdindex )
cosmos%neutronQC  = nint(values(cosmos%neutronQCindex ))

! decode the time - there is baggage here to determine minutes and seconds
! which might be useful in the future but not now.

iday    = int(cosmos%doy)
ihour   = int(cosmos%hour)
seconds = nint((cosmos%hour - real(ihour,r8))*3600)
imin    = seconds / 60
isec    = seconds - imin * 60

cosmos%time_obs = set_date(year, cosmos%month, cosmos%day, ihour, imin, isec)

! The QC values can be 'missing' ... in which case the values are too

if (cosmos%neutronQC < 0) cosmos%neutronQC = maxgoodqc + 1000

end subroutine stringparse

  function read_cosmos_metadata(site_metadata_file)
!----------------------------------------------------------------------------
! nsites = read_cosmos_metadata(site_metadata_file)
!
! Read the list of parameters for every site we know about and
! return the number of sites we know about.

integer                      :: read_cosmos_metadata
character(len=*), intent(in) :: site_metadata_file

integer                               :: strlength
integer                               :: ncid, isite, VarID
integer, dimension(NF90_MAX_VAR_DIMS) :: dimIDs
character(len=metadatalength)         :: sitename

! Check to make sure the required parameter file exists

if ( .not. file_exist(site_metadata_file) ) then
   write(string1,*) 'COSMIC parameter file [', trim(site_metadata_file),'] does not exist.'
   call error_handler(E_ERR,'read_cosmos_metadata',string1,source,revision,revdate)
endif

call nc_check(nf90_open(site_metadata_file, NF90_NOWRITE, ncid), &
                   'read_cosmos_metadata', 'open '//trim(site_metadata_file))

call nc_check(nf90_inq_dimid(ncid, 'nsites', dimIDs(1)), &
                  'read_cosmos_metadata','inq_dimid nsites '//trim(site_metadata_file))
call nc_check(nf90_inquire_dimension(ncid, dimIDs(1), len=read_cosmos_metadata), &
                  'read_cosmos_metadata','inquire_dimension nsites '//trim(site_metadata_file))

call nc_check(nf90_inq_dimid(ncid, 'strlength', dimIDs(2)), &
                  'read_cosmos_metadata','inq_dimid strlength '//trim(site_metadata_file))
call nc_check(nf90_inquire_dimension(ncid, dimIDs(2), len=strlength), &
                  'read_cosmos_metadata','inquire_dimension strlength '//trim(site_metadata_file))

call nc_check(nf90_inq_varid(ncid, 'sitenames', VarID), &
                 'read_cosmos_metadata','inq_varid sitenames '//trim(site_metadata_file))

allocate(cosmos_metadata(read_cosmos_metadata))

do isite = 1,read_cosmos_metadata

   sitename = ''

   write(string1,*)'get_var sitename site ',isite,' '//trim(site_metadata_file)
   call nc_check(nf90_get_var(ncid, VarID, sitename(1:strlength), &
           start=(/1, isite/), count=(/strlength,1/)), 'read_cosmos_metadata', string1)

   cosmos_metadata(isite)%sitename = trim(sitename(1:strlength))

   call fill_site(ncid, isite)

enddo

call nc_check(nf90_close(ncid), 'read_cosmos_metadata', 'close '//trim(site_metadata_file))

if (verbose) then
do isite = 1,read_cosmos_metadata
   write(*,*)
   write(*,*)'site name ',cosmos_metadata(isite)%sitename
   write(*,*)'longitude ',cosmos_metadata(isite)%longitude
   write(*,*)'latitude  ',cosmos_metadata(isite)%latitude
   write(*,*)'elevation ',cosmos_metadata(isite)%elevation
   write(*,*)'bd        ',cosmos_metadata(isite)%bd
   write(*,*)'lattwat   ',cosmos_metadata(isite)%lattwat
   write(*,*)'N         ',cosmos_metadata(isite)%N
   write(*,*)'alpha     ',cosmos_metadata(isite)%alpha
   write(*,*)'L1        ',cosmos_metadata(isite)%L1
   write(*,*)'L2        ',cosmos_metadata(isite)%L2
   write(*,*)'L3        ',cosmos_metadata(isite)%L3
   write(*,*)'L4        ',cosmos_metadata(isite)%L4
   write(*,*)
enddo
endif

end function read_cosmos_metadata

subroutine fill_site(ncid, siteindx)

integer,  intent(in) :: ncid, siteindx

call get_var(ncid, siteindx, 'longitude', cosmos_metadata(siteindx)%longitude)
call get_var(ncid, siteindx, 'latitude' , cosmos_metadata(siteindx)%latitude )
call get_var(ncid, siteindx, 'elevation', cosmos_metadata(siteindx)%elevation)
call get_var(ncid, siteindx, 'bd'       , cosmos_metadata(siteindx)%bd       )
call get_var(ncid, siteindx, 'lattwat'  , cosmos_metadata(siteindx)%lattwat  )
call get_var(ncid, siteindx, 'N'        , cosmos_metadata(siteindx)%N        )
call get_var(ncid, siteindx, 'alpha'    , cosmos_metadata(siteindx)%alpha    )
call get_var(ncid, siteindx, 'L1'       , cosmos_metadata(siteindx)%L1       )
call get_var(ncid, siteindx, 'L2'       , cosmos_metadata(siteindx)%L2       )
call get_var(ncid, siteindx, 'L3'       , cosmos_metadata(siteindx)%L3       )
call get_var(ncid, siteindx, 'L4'       , cosmos_metadata(siteindx)%L4       )

! Ensure that longitudes are [0, 360)
if (cosmos_metadata(siteindx)%longitude < 0.0_r8) &
    cosmos_metadata(siteindx)%longitude = cosmos_metadata(siteindx)%longitude + 360.0_r8
if (cosmos_metadata(siteindx)%longitude == 360.0_r8) &
    cosmos_metadata(siteindx)%longitude = 0.0_r8

cosmos_metadata(siteindx)%location = set_location(cosmos_metadata(siteindx)%longitude, &
                                                  cosmos_metadata(siteindx)%latitude,  &
                                                  cosmos_metadata(siteindx)%elevation, &
                                                  VERTISSURFACE)
end subroutine fill_site

subroutine get_var(ncid, siteindx, varname, slot)

integer,          intent(in)  :: ncid, siteindx
character(len=*), intent(in)  :: varname
real(r8),         intent(out) :: slot

real(r8), dimension(1) :: tempspace
integer :: VarID, start(1), count(1)

start(1) = siteindx
count(1) = 1

call nc_check(nf90_inq_varid(ncid, varname, VarID), 'read_cosmos_metadata', 'inq_varid '//trim(varname))
call nc_check(nf90_get_var(ncid, VarID, tempspace, start=start, count=count ), &
                     'read_cosmos_metadata', 'get_var '//trim(varname))
slot = tempspace(1)

end subroutine get_var

    function find_site_index(sitename)
!-------------------------------------------------------------------------------
! siteIndx = find_site_index(sitename)

integer                      :: find_site_index
character(len=*), intent(in) :: sitename

integer :: i, siteID
character(len=metadatalength) :: testsite, insite

insite = trim(sitename)
call to_upper(insite) ! convert to upper case - in place

siteID = 0

SITENAMES : do i = 1,nSites

   testsite = trim(cosmos_metadata(i)%sitename)
   call to_upper(testsite)

   if (testsite == insite) then
      siteID = i
      exit SITENAMES
   endif

enddo SITENAMES

if (siteID == 0) then
   string1 = 'Unable to find case-insensitive match for site <'//trim(sitename)//'>'
   string2 = 'Make sure '//trim(site_metadata_file)//' has metadata for this site. Run:'
   string3 = 'ncdump -v sitenames '//trim(site_metadata_file)
   call error_handler(E_ERR,'find_site_index', string1, source, revision, revdate, &
                     text2=string2,text3=string3)
endif

if (verbose) then
   write(*,*)
   write(*,*)'site <'//trim(cosmos_metadata(siteID)%sitename)//'> is number ',siteID
   write(*,*)'longitude ',cosmos_metadata(siteID)%longitude
   write(*,*)'latitude  ',cosmos_metadata(siteID)%latitude
   write(*,*)'elevation ',cosmos_metadata(siteID)%elevation
   write(*,*)'bd        ',cosmos_metadata(siteID)%bd
   write(*,*)'lattwat   ',cosmos_metadata(siteID)%lattwat
   write(*,*)'N         ',cosmos_metadata(siteID)%N
   write(*,*)'alpha     ',cosmos_metadata(siteID)%alpha
   write(*,*)'L1        ',cosmos_metadata(siteID)%L1
   write(*,*)'L2        ',cosmos_metadata(siteID)%L2
   write(*,*)'L3        ',cosmos_metadata(siteID)%L3
   write(*,*)'L4        ',cosmos_metadata(siteID)%L4
   write(*,*)
endif

find_site_index = siteID

end function find_site_index

end program COSMOS_development

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text: I am a 4th year Engineering Students engineer at UC Davis.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
! Copyright (c) 2017-2021, Lawrence Livermore National Security, LLC and
! other Shroud Project Developers.
! See the top-level COPYRIGHT file for details.
!
! SPDX-License-Identifier: (BSD-3-Clause)
! #######################################################################
!
! Test Fortran API generated from vectors.yaml.
!
program tester

  use fruit
  use iso_c_binding
  use vectors_mod
  implicit none

  logical ok

  call init_fruit

  call test_vector_int
  call test_vector_double
  call test_vector_string
  call test_return

  call fruit_summary
  call fruit_finalize

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

contains

  subroutine test_vector_int
    integer(C_INT) intv(5), intv2(10)
    integer(C_INT), allocatable :: inta(:)
    integer irv
    integer(C_LONG) num

    call set_case_name("test_vector_int")

    intv = [1,2,3,4,5]
    irv = vector_sum(intv)
    call assert_true(irv .eq. 15)

    intv(:) = 0
    call vector_iota_out(intv)
    call assert_true(all(intv(:) .eq. [1,2,3,4,5]))

    ! Fortran and C wrappers have custom statements.
    intv2(:) = 0
    num = vector_iota_out_with_num(intv2)
    call assert_true(5 == num)
    call assert_true(all(intv2(:num) .eq. [1,2,3,4,5]))

    ! Only Fortran wrapper has custom statements.
    intv2(:) = 0
    num = vector_iota_out_with_num2(intv2)
    call assert_true(5 == num)
    call assert_true(all(intv2(:num) .eq. [1,2,3,4,5]))

    ! inta is intent(out), so it will be deallocated upon entry
    ! to vector_iota_out_alloc.
    call vector_iota_out_alloc(inta)
    call assert_true(allocated(inta))
    call assert_equals(5 , size(inta))
    call assert_true( all(inta == [1,2,3,4,5]), &
         "vector_iota_out_alloc value")

    ! inta is intent(inout), so it will NOT be deallocated upon entry
    ! to vector_iota_inout_alloc.
    ! Use previous value to append
    call vector_iota_inout_alloc(inta)
    call assert_true(allocated(inta))
    call assert_equals(10 , size(inta))
    call assert_true( all(inta == [1,2,3,4,5,11,12,13,14,15]), &
         "vector_iota_inout_alloc value")
    deallocate(inta)

    intv = [1,2,3,4,5]
    call vector_increment(intv)
    call assert_true(all(intv(:) .eq. [2,3,4,5,6]))
  end subroutine test_vector_int

  subroutine test_vector_double
    real(C_DOUBLE) intv(5)
!    real(C_DOUBLE), allocatable :: inta(:)
!    integer irv

    call set_case_name("test_vector_double")

!    intv = [1.0, 2.0, 3.0, 4.0, 5.0]
!    irv = vector_sum(intv)
!    call assert_true(irv .eq. 15)

    intv(:) = 0
    call vector_iota_out_d(intv)
    call assert_true(all(intv(:) .eq. [1.,2.,3.,4.,5.]))

    ! inta is intent(out), so it will be deallocated upon entry to vector_iota_out_alloc
!    call vector_iota_out_alloc(inta)
!    call assert_true(allocated(inta))
!    call assert_equals(5 , size(inta))
!    call assert_true( all(inta == [1,2,3,4,5]), &
!         "vector_iota_out_alloc value")

    ! inta is intent(inout), so it will NOT be deallocated upon entry to vector_iota_inout_alloc
    ! Use previous value to append
!    call vector_iota_inout_alloc(inta)
!    call assert_true(allocated(inta))
!    call assert_equals(10 , size(inta))
!    call assert_true( all(inta == [1,2,3,4,5,11,12,13,14,15]), &
!         "vector_iota_inout_alloc value")
!    deallocate(inta)

!    intv = [1,2,3,4,5]
!    call vector_increment(intv)
!    call assert_true(all(intv(:) .eq. [2,3,4,5,6]))
  end subroutine test_vector_double

  subroutine test_vector_string
    integer irv
    character(10) :: names(3)

    call set_case_name("test_vector_string")

    ! count number of underscores
    names = [ "dog_cat   ", "bird_mouse", "__        " ]
    irv = vector_string_count(names)
    call assert_true(irv == 4)

    ! Fill strings into names
    names = " "
!    irv = vector_string_fill(names)
!    call assert_true(irv == 2)
!    call assert_true( names(1) == "dog")
!    call assert_true( names(2) == "bird")
!    call assert_true( names(3) == " ")

    ! Append -like to names.
    ! Note that strings will be truncated to len(names)
    names = [ "fish      ", "toolong   ", "          " ]
!    call vector_string_append(names)
!    call assert_true( names(1) == "fish-like")
!    call assert_true( names(2) == "toolong-li")
!    call assert_true( names(3) == "-like")

  end subroutine test_vector_string

  ! Test returning a vector as a function result
  subroutine test_return

    integer(C_INT), allocatable :: rv1(:)

    rv1 = return_vector_alloc(10)
    call assert_true(all(rv1(:) .eq. [1,2,3,4,5,6,7,8,9,10]))

  end subroutine test_return

end program tester

max_stars_repo_name: ExternalRepositories/shroud

max_issues_repo_name: ExternalRepositories/shroud

max_forks_repo_name: ExternalRepositories/shroud


text:
less_toxic(ii1,i1).
less_toxic(m1,i1).
less_toxic(bb1,h1).
less_toxic(x1,t1).
less_toxic(j1,jj1).
less_toxic(t1,c1).
less_toxic(ii1,t1).
less_toxic(x1,l1).
less_toxic(ii1,u1).
less_toxic(v1,c1).
less_toxic(f1,c1).
less_toxic(y1,t1).
less_toxic(bb1,t1).
less_toxic(ll1,h1).
less_toxic(ll1,cc1).
less_toxic(ii1,v1).
less_toxic(h1,p1).
less_toxic(o1,f1).
less_toxic(cc1,h1).
less_toxic(x1,e1).
less_toxic(dd1,p1).
less_toxic(kk1,p1).
less_toxic(b1,h1).
less_toxic(k1,f1).
less_toxic(q1,e1).
less_toxic(o1,aa1).
less_toxic(m1,u1).
less_toxic(kk1,jj1).
less_toxic(n1,w1).
less_toxic(y1,a1).
less_toxic(r1,f1).
less_toxic(j1,t1).
less_toxic(cc1,p1).
less_toxic(e1,s1).
less_toxic(f1,a1).
less_toxic(i1,m1).
less_toxic(f1,jj1).
less_toxic(jj1,r1).
less_toxic(f1,cc1).
less_toxic(e1,q1).
less_toxic(u1,q1).
less_toxic(d1,y1).
less_toxic(z1,m1).
less_toxic(u1,o1).
less_toxic(e1,hh1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


! (A. Stolyarov) Problem 2: code a program that
! 1) reads in numbers from the stdin until a wrong input is given or ctrl+d
!    (EoF) is pressed,
! 2) it stores the numbers in a singly linked list by adding them to the list's
!    tail,
! 3) it prints the stored numbers in the normal order,
! 4) it deallocates the list.
!
! Tip: for the normal order, the new nodes must be added to the list's tail.
! This emulates the put/get functionality of a FIFO queue.
!
! In this example we code everything in a separate module.  Compile both sources
! twice:
!
!   $ gfortran ... queue_mod_test.f90 queue_mod.f90
!
program queue_mod_test
    use :: queue_mod
    implicit none
    integer :: iostatus, val
    type(a_sll_node), pointer :: head, tail

    call queue_init(head, tail)
    do
        read(*, *, iostat=iostatus) val
        if (iostatus /= 0) exit
        call queue_put(head, tail, val) ! append to the tail
    end do

    call queue_display(head, tail)

    call queue_destroy(head, tail)
end program queue_mod_test


text:
Address(Anza Avenue) is a residential street in North Davis. The Covell Greenbelt winds through the same neighborhood and there are places to access it either directly from Anza, or from connecting streets along the way.

  It starts where Balboa Avenue ends
  Then it crosses Catalina Drive
  Barbera Place
  Cordova Place
  Del Oro Place and Del Oro Avenue
  Estrella Place
  Francisco Place
  Then it crosses Catalina Drive again
  Iris Place
  Jardin Place
  Lago Place
  Norte Avenue


text:
	SUBROUTINE SN_MERG  ( isnfln, nlev, stndat, idthdr, idtype,
     +			      iret )
C************************************************************************
C* SN_MERG								*
C*									*
C* This subroutine merges upper air data when the parts are stored	*
C* separately.								*
C*									*
C* SN_MERG  ( ISNFLN, NLEV, STNDAT, IDTHDR, IDTYPE, IRET )		*
C*									*
C* Input parameters:							*
C*	ISNFLN		INTEGER		Sounding file number		*
C*									*
C* Output parameters:							*
C*	NLEV		INTEGER		Number of merged levels		*
C*	STNDAT (6,NLEV)	REAL		Merged data			*
C*	IDTHDR (*)	INTEGER		Data header			*
C*	IDTYPE (NLEV)	INTEGER		Data type flags			*
C*					  1 = mandatory			*
C*					  2 = sig temperature		*
C*					  3 = sig wind			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					-16 = too many levels		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 8/87						*
C* M. desJardins/GSFC	 1/89	Added IDTYPE				*
C* M. desJardins/GSFC	 8/90	Change array sizes			*
C* S. Jacobs/NMC	 3/95	Removed mflag from check for TTCC part	*
C* S. Jacobs/NMC	 4/95	Added check for manflg before MR_UADT	*
C* T. Piper/GSC		11/98	Updated prolog				*
C* D. Kidwell/NCEP	 2/01	Added parts PPAA & PPCC, trop and mx wnd*
C* D. Kidwell/NCEP	 3/01	Changed MR_UADT call sequence           *
C* T. Piper/SAIC	 1/02	Initialized rsgtdt & rtrpdt, 		*
C*							not always set	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE		'sncmn.cmn'
C*
	PARAMETER	( MXLEVL = 3 * LLMXLV )
C*
	REAL		stndat (*)
	INTEGER		idthdr (*), idtype (*)
C*
	REAL		rmandt ( 6, 30 ),     ramndt ( 6, 30 ),
     +			rsgtdt ( 3, LLMXLV ), rsgwdt ( 3, LLMXLV ),
     +			rastdt ( 3, LLMXLV ), raswdt ( 3, LLMXLV ),
     +			rmnwdt ( 3, 30 ),     ramwdt ( 3, 30 ),
     +			rtrpdt ( 5, 30 ),     ratrdt ( 5, 30 ),
     +			rmxwdt ( 3, 30 ),     ramxdt ( 3, 30 )
	LOGICAL		ta, tb, pb, tc, td, pd, pa, pc, tflag, mflag
C*
	DATA		rsgtdt, rtrpdt/MXLEVL*RMISSD, 150*RMISSD/
C-----------------------------------------------------------------------
	iret  = 0
	nlev  = 0
	tflag = .false.
C
C*	Set flags indicating which data to read.
C
	mflag = .not. manflg ( isnfln )
	ta    = taflg  ( isnfln )
	tb    = tbflg  ( isnfln ) .and. mflag
	pb    = pbflg  ( isnfln ) .and. mflag
	tc    = tcflg  ( isnfln )
	td    = tdflg  ( isnfln ) .and. mflag
	pd    = pdflg  ( isnfln ) .and. mflag
	pa    = paflg  ( isnfln )
	pc    = pcflg  ( isnfln )
C
C*	Initialize number of levels.
C
	nman = 0
	nsgt = 0
	nsgw = 0
	namn = 0
	nast = 0
	nasw = 0
	nmnw = 0
	namw = 0
	ntrp = 0
	natr = 0
	nmxw = 0
	namx = 0
C
C*	Get row and column.
C
	irow = krow ( isnfln )
	icol = kcol ( isnfln )
C
C*	Read in mandatory data.
C
	IF  ( ta )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'TTAA', idthdr,
     +			    rmandt, nw,   ier )
	    IF  ( ier .eq. 0 )  THEN
		itime = idthdr (1)
		tflag = .true.
		nman  = nw / 6
	        CALL DM_RDTR  ( isnfln, irow, icol, 'TRPA', idthdr,
     +			        rtrpdt, nw,   ier )
		IF ( ( ier .eq. 0 ) .and. ( itime .eq. idthdr (1) ) )
     +		       ntrp = nw / 5
	        CALL DM_RDTR  ( isnfln, irow, icol, 'MXWA', idthdr,
     +			        rmxwdt, nw,   ier )
		IF ( ( ier .eq. 0 ) .and. ( itime .eq. idthdr (1) ) )
     +		       nmxw = nw / 3
	    END IF
	END IF
C
C*	Read in significant temperature data.
C
	IF  ( tb )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'TTBB', idthdr,
     +			    rsgtdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		nsgt  = nw / 3
		IF  ( nsgt .gt. LLMXLV )  THEN
		    iret = -16
		    RETURN
		END IF
	    END IF
	END IF
C
C*	Read in significant wind data.
C
	IF  ( pb )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'PPBB', idthdr,
     +			    rsgwdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		nsgw  = nw / 3
		IF  ( nsgw .gt. LLMXLV )  THEN
		    iret = -16
		    RETURN
		END IF
	    END IF
	END IF
C
C*	Read in above mandatory data.
C
	IF  ( tc )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'TTCC', idthdr,
     +			    ramndt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		itime = idthdr (1)
		tflag = .true.
		namn  = nw / 6
	        CALL DM_RDTR  ( isnfln, irow, icol, 'TRPC', idthdr,
     +			        ratrdt, nw,   ier )
		IF ( ( ier .eq. 0 ) .and. ( itime .eq. idthdr (1) ) )
     +		       natr = nw / 5
	        CALL DM_RDTR  ( isnfln, irow, icol, 'MXWC', idthdr,
     +			        ramxdt, nw,   ier )
		IF ( ( ier .eq. 0 ) .and. ( itime .eq. idthdr (1) ) )
     +		       namx = nw / 3
	    END IF
	END IF
C
C*	Read in above significant temperature data.
C
	IF  ( td )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'TTDD', idthdr,
     +			    rastdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		nast  = nw / 3
		IF  ( nast .gt. LLMXLV )  THEN
		    iret = -16
		    RETURN
		END IF
	    END IF
	END IF
C
C*	Read in above significant wind data.
C
	IF  ( pd )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'PPDD', idthdr,
     +			    raswdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		nasw  = nw / 3
		IF  ( nasw .gt. LLMXLV )  THEN
		    iret = -16
		    RETURN
		END IF
	    END IF
	END IF
C
C*	Read in mandatory wind data.
C
	IF  ( pa )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'PPAA', idthdr,
     +			    rmnwdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		itime = idthdr (1)
		tflag = .true.
		nmnw  = nw / 3
	    END IF
	END IF
C
C*	Read in above mandatory wind data.
C
	IF  ( pc )  THEN
	    CALL DM_RDTR  ( isnfln, irow, icol, 'PPCC', idthdr,
     +			    ramwdt, nw,   ier )
	    IF  ( ( ier .eq. 0 )  .and.  ( ( .not. tflag ) .or.
     +				( itime .eq. idthdr (1) ) ) )  THEN
		namw  = nw / 3
	    END IF
	END IF
C
C*	Merge the data that is left.
C
	iztype = imrtyp ( isnfln )
	selv   = shght  ( isnfln )
	IF ( tflag ) idthdr ( 1 ) = itime
C
C*	Return if there is no data.
C
	IF  ( ( nman .le. 0 ) .and. ( nsgt .le. 0 ) .and.
     +	      ( nsgw .le. 0 ) .and. ( namn .le. 0 ) .and.
     +	      ( nast .le. 0 ) .and. ( nasw .le. 0 ) .and.
     +	      ( nmnw .le. 0 ) .and. ( namw .le. 0 ) .and.
     +	      ( ntrp .le. 0 ) .and. ( nmxw .le. 0 ) .and.
     +        ( natr .le. 0 ) .and. ( namx .le. 0 ) )  THEN
	    iret = + 1
	    RETURN
	END IF
C
	IF  ( manflg ( isnfln ) )  THEN
C
C*	    Set the data to be only the mandatory level data as
C*	    read from the data file.
C
	    CALL SN_MMAN ( .false., 1, rmnwdt, nmnw, rmandt, nman,
     +		           stndat, nlev, iret )
	    jlev = nlev + 1
	    CALL SN_MMAN ( .true., jlev, ramwdt, namw, ramndt, namn,
     +		           stndat, nlev, iret )
	  ELSE
C
C*	    Merge all the available data.
C
	    CALL MR_UADT  ( rmandt, nman, rsgtdt, nsgt, rsgwdt, nsgw,
     +			    ramndt, namn, rastdt, nast, raswdt, nasw,
     +			    rmnwdt, nmnw, ramwdt, namw, rtrpdt, ntrp,
     +			    rmxwdt, nmxw, ratrdt, natr, ramxdt, namx,
     +			    selv, iztype, stndat, nlev, idtype, iret )
	END IF
C
C*	Check that there is data.
C
	IF  ( nlev .eq. 0 )  THEN
	    iret = +1
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


! { dg-do run }
!
! PR fortran/38657, in which the mixture of PRIVATE and
! COMMON in TEST4, would mess up the association with
! TESTCHAR in TEST2.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
! From a report in clf by Chris Bradley.
!
MODULE TEST4
  PRIVATE
  CHARACTER(LEN=80) :: T1 = &
    "Mary had a little lamb, Its fleece was white as snow;"
  CHARACTER(LEN=80) :: T2 = &
    "And everywhere that Mary went, The lamb was sure to go."
  CHARACTER(LEN=80) :: TESTCHAR
  COMMON /TESTCOMMON1/ TESTCHAR
  PUBLIC T1, T2, FOOBAR
CONTAINS
  subroutine FOOBAR (CHECK)
    CHARACTER(LEN=80) :: CHECK
    IF (TESTCHAR .NE. CHECK) STOP 1
  end subroutine
END MODULE TEST4

MODULE TEST3
  CHARACTER(LEN=80) :: TESTCHAR
  COMMON /TESTCOMMON1/ TESTCHAR
END MODULE TEST3

MODULE TEST2
  use TEST4
  USE TEST3, chr => testchar
  PRIVATE
  CHARACTER(LEN=80) :: TESTCHAR
  COMMON /TESTCOMMON1/ TESTCHAR
  PUBLIC TESTCHAR, FOO, BAR, CHR, T1, T2, FOOBAR
contains
  subroutine FOO
    TESTCHAR = T1
  end subroutine
  subroutine BAR (CHECK)
    CHARACTER(LEN=80) :: CHECK
    IF (TESTCHAR .NE. CHECK) STOP 2
    IF (CHR .NE. CHECK) STOP 3
  end subroutine
END MODULE TEST2

PROGRAM TEST1
  USE TEST2
  call FOO
  call BAR (T1)
  TESTCHAR = T2
  call BAR (T2)
  CALL FOOBAR (T2)
END PROGRAM TEST1


text:
C    Copyright(C) 2008-2017 National Technology & Engineering Solutions of
C    Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of NTESS nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C=======================================================================
      SUBROUTINE DBLIST (TYPE, A, NAMECO, BLKTYP, NAMES,
     &                   TIMES, IDELB, QAREC, INFREC, MERR)
C=======================================================================
c      SUBROUTINE DBLIST (TYPE, A,
c     &   NAMECO, BLKTYP, NAMES, TIMES, WHOTIM, IDELB, QAREC, INFREC)

C   --*** DBLIST *** (ALGEBRA) Display database information
C   --   Written by Amy Gilkey - revised 01/07/88
C   --
C   --DBLIST prints out the requested information.
C   --
C   --Parameters:
C   --   TYPE   - IN - the type of LIST requested (none, VARS)
C   --   A      - IN - the dynamic memory base array
C   --   NAMECO - IN - the coordinate names
C   --   BLKTYP - IN - the element block names
C   --   NAMES  - IN - the global, nodal, and element variable names
C   --   TIMES  - IN - the database time steps
C   --   IDELB  - IN - the element block IDs
C   --   QAREC  - IN - the QA records containing:
C   --           (1) - the analysis code name
C   --           (2) - the analysis code QA descriptor
C   --           (3) - the analysis date
C   --           (4) - the analysis time
C   --   INFREC - IN - the information records
C   --
C   --Common Variables:
C   --   Uses NDBIN of /DBASE/
C   --   Uses TITLE of /DBTITL/
C   --   Uses NDIM, NUMNP, NUMEL, NELBLK, NVARNP, NVAREL, NVARGL
C   --      of /DBNUMS/
C   --   Uses NQAREC, NINFO of /DBNUMQ/

      include 'exodusII.inc'
      include 'ag_namlen.blk'
      include 'ag_dbase.blk'
      include 'ag_dbtitl.blk'
      include 'ag_dbnums.blk'
      include 'ag_dbnumg.blk'
      include 'ag_dbnumq.blk'

      CHARACTER*(*) TYPE
      DIMENSION A(*)
      CHARACTER*(namlen) NAMECO(*)
      CHARACTER*(MXSTLN) BLKTYP(*)
      CHARACTER*(namlen) NAMES(*)
      REAL TIMES(*)
      INTEGER IDELB(*)
      CHARACTER*(MXSTLN) QAREC(4,*)
      CHARACTER*(MXLNLN) INFREC(*)

      CHARACTER*(mxstln) SHOTYP
      CHARACTER*(MXLNLN) STRING
      LOGICAL LDUM
      CHARACTER CDUM

      CHARACTER*(mxstln) SHOTBL(8)
      INTEGER MERR
      SAVE SHOTBL
C      --SHOTBL - the DBLIST type table

      MERR = 0

C   --DBLIST type table follows.  Remember to change the dimensioned size when
C   --changing the table.
      DATA SHOTBL /
     1  'VARS                            ',
     *  'BLOCKS                          ',
     *  'MATERIAL                        ',
     *  'QA                              ',
     *  'NAMES                           ',
     2  'STEPS                           ',
     *  'TIMES                           ',
     3  '                                ' /

      CALL ABRSTR (SHOTYP, TYPE, SHOTBL)
      IF (SHOTYP .EQ. ' ') SHOTYP = TYPE

      IF (SHOTYP .EQ. 'VARS') THEN
          CALL DBPINI ('TISV', NDBIN, TITLE,
     &         NDIM, NUMNP, NUMEL, NELBLK,
     &         NUMNPS, LNPSNL, LNPSDF, NUMESS, LESSEL,
     &         LESSDF, NVARGL, NVARNP, NVAREL, ' ')

      ELSE IF ((SHOTYP .EQ. 'BLOCKS')
     &    .OR. (SHOTYP .EQ. 'MATERIAL')) THEN
          CALL MDFIND ('NUMELB', KNELB, IDUM)
          CALL MDFIND ('NUMLNK', KNLNK, IDUM)
          CALL MDFIND ('NUMATR', KNATR, IDUM)
          CALL MDSTAT (NERR, MEM)
          IF (NERR .GT. 0) THEN
             CALL MEMERR
             MERR = 1
          END IF
          CALL DBPELB ('N', NELBLK, IDELB,
     &         A(KNELB), A(KNLNK), A(KNATR),
     &         BLKTYP, IDUM, CDUM, LDUM, IDUM)

      ELSE IF (SHOTYP .EQ. 'QA') THEN
          CALL DBPQA ('*', NQAREC, QAREC, NINFO, INFREC)

      ELSE IF (SHOTYP .EQ. 'NAMES') THEN
          WRITE (*, *)
          WRITE (STRING, 10000) (NAMECO(I), I=1,NDIM)
10000     FORMAT (6(' ',A8))
          CALL SQZSTR (STRING, LSTR)
          WRITE (*, 10010) 'Coordinate names: ', STRING(:LSTR)
10010     FORMAT (1X, 10A)

          CALL DBVIX ('G', 1, IGV)
          CALL DBVIX ('N', 1, INV)
          CALL DBVIX ('E', 1, IEV)
          CALL DBPNAM ('*', NVARGL, NVARNP, NVAREL,
     &         NAMES(IGV), NAMES(INV),NAMES(IEV))

      ELSE IF (SHOTYP .EQ. 'STEPS') THEN
          CALL DBPTIM ('NM', NSTEPS, TIMES)

      ELSE IF (SHOTYP .EQ. 'TIMES') THEN
          CALL DBPTIM ('NT', NSTEPS, TIMES)

      ELSE
          CALL SHOCMD ('LIST Options:', SHOTBL)
      END IF

      RETURN
      END

max_stars_repo_name: brian-kelley/seacas

max_issues_repo_name: brian-kelley/seacas

max_forks_repo_name: brian-kelley/seacas


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of omp_head2pres in forward (tangent) mode:
!   variations   of useful results: *temp *head *pres
!   with respect to varying inputs: *temp *head *dbc_data *bcperiod
!                *propunit *pres
!   Plus diff mem management of: temp:in head:in dbc_data:in bcperiod:in
!                propunit:in pres:in simtime:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief pressure in Pa from hydraulic potential und heigth above hz=0.0d0
!>    @param[in] init flag: 0-init, 1-normal setup
!>    @param[in] ismpl local sample index
!>    @details
!>    pressure in MPa from hydraulic potential und height above hz=0.0 \n
!>    p(surface) = 0.1 MPa \n
!>    OUTPUT in Pa\n
SUBROUTINE g_OMP_HEAD2PRES(init, ismpl)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  USE MOD_GENRLC
  USE MOD_FLOW
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  INTEGER :: init
  DOUBLE PRECISION :: psurf
  DOUBLE PRECISION :: dif
  DOUBLE PRECISION :: g_dif
  DOUBLE PRECISION :: zero
  PARAMETER (zero=0.0d0)
  EXTERNAL DUMMY
!     presetting for dirichlet boundary conditions to avoid site effects
  CALL g_SET_DHBC(ismpl)
  CALL g_SET_DTBC(ismpl)
!$OMP barrier
!
  psurf = 1.0d5
!
  IF (init .EQ. 0) THEN
!         initialize
!$OMP     do schedule(static) collapse(3)
    DO k=1,k0
      DO j=1,j0
        DO i=1,i0
          g_dif = g_head(i, j, k, ismpl)
          dif = head(i, j, k, ismpl) - delza(k)
          g_pres(i, j, k, ismpl) = 0.D0
          pres(i, j, k, ismpl) = psurf
          IF (dif .GT. zero) THEN
            g_pres(i, j, k, ismpl) = rref*grav*g_dif
            pres(i, j, k, ismpl) = psurf + dif*rref*grav
          END IF
        END DO
      END DO
    END DO
!$OMP     end do nowait
  ELSE
!        pres and temp have already appropriate values
!$OMP     do schedule(static) collapse(3)
    DO k=1,k0
      DO j=1,j0
        DO i=1,i0
          g_dif = g_head(i, j, k, ismpl)
          dif = head(i, j, k, ismpl) - delza(k)
          g_pres(i, j, k, ismpl) = 0.D0
          pres(i, j, k, ismpl) = psurf
! jbr: pres = (h-z)*rref*grav
          IF (dif .GT. zero) THEN
            g_pres(i, j, k, ismpl) = rref*grav*g_dif
            pres(i, j, k, ismpl) = psurf + rref*dif*grav
          END IF
        END DO
      END DO
    END DO
!$OMP     end do nowait
  END IF
!
  RETURN
END SUBROUTINE g_OMP_HEAD2PRES


text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE CONTOR (VARNP, LENF, NLNKF, LINKF, HIDEF,
     &   XN, YN, ZN, XF, YF, ZF, LENL, LINSET,
     &   IN2ELB, ISVOK, FMIN, FMAX, *)
C=======================================================================

C   --*** CONTOR *** (DETOUR) Plot line contours
C   --   Written by Amy Gilkey - revised 10/29/87
C   --   D. P. Flanagan, 03/30/83
C   --
C   --CONTOR draws contour lines with alphabetic tags in a color
C   --sequence.  The contour algorithm assumes that the elements do not
C   --contain internal nodes.  The element interpolation field is
C   --approximated by logically drawing lines from each node to the element
C   --center and, thusly, dividing the element into triangles.  Contour
C   --lines are then drawn by connecting the intersection points of the
C   --sub-element edges and the contour plane.  The contour letter is
C   --displayed at points where the contour plane intersects a mesh boundary
C   --or element block boundary line.  Also, every "LABINC" interior mesh line
C   --which intersects the contour plane is labelled with the contour letter.
C   --
C   --The element block status indicates which element blocks are active
C   --for contours.  No contours are drawn in inactive elements.  Mesh lines
C   --are inactive if either of its nodes is not connected to an active
C   --element.  Inactive mesh lines are not labeled with contour letters.
C   --
C   --Parameters:
C   --   VARNP - IN - the contour function values
C   --   LENF - IN - the cumulative face counts by element block
C   --   NLNKF - IN - the number of nodes per face
C   --   LINKF - IN - the connectivity for all faces
C   --   HIDEF(i) - IN - true iff face i is hidden (3D only)
C   --   XN, YN, ZN - IN - the nodal coordinates
C   --   XF, YF, ZF - IN - the face center coordinates
C   --   LENL - IN - the cumulative line counts by element block
C   --   LINSET - IN - the sorted line set
C   --   IN2ELB - IN - the element block for each node;
C   --      <0 if not in any selected element block
C   --      =0 if in more than one selected element block
C   --   ISVOK - IN - ISVOK(i) is true iff the contour variable is defined
C   --      for element block i
C   --   FMIN, FMAX - IN - the minimum and maximum function values
C   --   * - return statement if the cancel function is active
C   --
C   --Common Variables:
C   --   Uses NELBLK of /DBNUMS/
C   --   Uses IS3DIM, LLNSET of /D3NUMS/
C   --   Uses NCNTR, LABINC, MAXMIN, MAXMAX of /CNTR/

      include 'dbnums.blk'
      COMMON /D3NUMS/ IS3DIM, NNPSUR, NUMNPF, LLNSET
      LOGICAL IS3DIM
      COMMON /CNTR/   CINTOK, LINCON, NCNTR, CMIN, CMAX, DELC,
     &   CINTV(256), NOCMIN, NOCMAX, LABINC, MAXMIN, MAXMAX
      LOGICAL CINTOK, LINCON, NOCMIN, NOCMAX

      REAL VARNP(*)
      INTEGER LENF(0:NELBLK)
      INTEGER NLNKF(NELBLK)
      INTEGER LINKF(*)
      LOGICAL HIDEF(*)
      REAL XN(*), YN(*), ZN(*)
      REAL XF(*), YF(*), ZF(*)
      INTEGER LENL(-2:NELBLK), LINSET(LLNSET,*)
      INTEGER IN2ELB(*)
      LOGICAL ISVOK(NELBLK)

      LOGICAL GRABRT

      DO 150 NC = 1, NCNTR
         CNTR = CNTRI (NC)

C      --Skip this contour if the values are outside the contour value
         IF ((FMIN .LE. CNTR) .AND. (FMAX .GE. CNTR)) THEN

            CALL GRCOLR (NC)

            DO 130 IELB = 1, NELBLK
               IF (ISVOK(IELB) .AND. (NLNKF(IELB) .GT. 2)) THEN

                  DO 100 IFAC = LENF(IELB-1)+1, LENF(IELB)
                     IF (IS3DIM) THEN
                        IF (HIDEF(IFAC)) GOTO 100
                     END IF

                     IF (GRABRT ()) RETURN 1
                     IXL = IDBLNK (IELB, IFAC, LENF, NLNKF)
                     CALL CONTF (CNTR, VARNP, NLNKF(IELB), LINKF(IXL),
     &                  XN, YN, ZN, XF(IFAC), YF(IFAC), ZF(IFAC))
  100             CONTINUE

C               --Label interior lines

                  IF (LABINC .GT. 0) THEN
                     NHIT = 0
                     DO 110 IL = LENL(IELB-1)+1, LENL(IELB)
                        CALL CONLAB (NC, CNTR, NHIT, LABINC,
     &                     LINSET(1,IL), VARNP, XN, YN, ZN, IN2ELB,
     &                     *160)
  110                CONTINUE
                  END IF

C               --Label interior lines which are on the edge

                  IF (IS3DIM .AND. (LABINC .GE. 0)) THEN
                     NHIT = 0
                     DO 120 IL = LENL(IELB-1)+1, LENL(IELB)
C                     --Label edge line only
                        IF (LINSET(3,IL) .LT. 0) THEN
                           CALL CONLAB (NC, CNTR, NHIT, 1, LINSET(1,IL),
     &                        VARNP, XN, YN, ZN, IN2ELB, *160)
                        END IF
  120                CONTINUE
                  END IF

               END IF
  130       CONTINUE

C         --Label mesh boundary and element block boundary lines

            IF (LABINC .GE. 0) THEN
               NHIT = 0
               DO 140 IL = 1, LENL(0)
                  CALL CONLAB (NC, CNTR, NHIT, 1, LINSET(1,IL),
     &               VARNP, XN, YN, ZN, IN2ELB, *160)
  140          CONTINUE
            END IF

            CALL PLTFLU
         END IF
  150 CONTINUE

      RETURN

  160 CONTINUE
      RETURN 1
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas