text:
C=======================================================================
C  IPVAR, Subroutine
C
C  Reads in genetic information for crop
C-----------------------------------------------------------------------
C  Revision       History
C  01/01/1990 GH  Written
C  05/28/1993 PWW Header revision and minor changes
C  12/14/2000 GH  Version correction
C  12/14/2005 CHP/PST Added new sorghum cultivar coefficients (optional)
C  02/06/2007 CHP Added alternate sugarcane parameters for CASUPRO
C  04/21/2007 GH  Added P3 and P4 coefficients for sorghum
C  09/16/2007 JIL New inputs for IXIM
!  11/08/2007 CHP Added 6X field for quality (= number of experiments used
!                 in estimation of parameters).  This field is read here,
!                 but not written to INP or INH files.
C  11/26/2007 CHP THRESH, SDPRO, SDLIP moved from eco to cul file
C  01/16/2008 GH  Added P2 and PANTH coefficients for sorghum
C  08/03/2009 FSR Added numerous variables for CASUPRO
C  06/30/2010 FSR Added PLF2 variable for CASUPRO
C  05/19/2011 GH  Updated for sorghum
C  02/25/2012 JZW add the PHINT data reading from *.cul for RICER
C  08/09/2012 GH  Updated for cassava
!  04/16/2013 CHP/KAD Added SALUS model
!  05/09/2013 CHP/FR/JZW Added N-wheat module
C-----------------------------------------------------------------------
C  INPUT  : FILEG,NSENS,VARNO,VARTY,VRNAME,PATHGE,ECONO
C
C  LOCAL  : LINE,BLANK,ANS,ERRKEY,C360,FILEGG,ERRNUM,LINVAR,LUNVAR,I,ISECT,
C           PATHL,NLOOP,NLVAR,FLAG,VAR
C
C  OUTPUT :
C-----------------------------------------------------------------------
C  Called : SEVAR SENS INPUT
C
C  Calls  : ERROR CLEAR IGNORE VERIFY
C-----------------------------------------------------------------------
C                         DEFINITIONS
C
C  HDLAY  :
C=======================================================================
      SUBROUTINE IPVAR (FILEG,NSENS,RNMODE,VARNO,VARTY,VRNAME,
     &                  PATHGE,ECONO, MODEL, ATLINE, CROP)

      IMPLICIT NONE

      INCLUDE 'COMGEN.blk'

      CHARACTER*1   LINE(80),RNMODE,BLANK,ANS
      CHARACTER*2   CROP
      CHARACTER*6   VARTY,VARNO,ERRKEY,ECONO
      CHARACTER*8   MODEL
      CHARACTER*12  FILEG
      CHARACTER*16  VRNAME
      CHARACTER*78  MSG(2)
      CHARACTER*80  PATHGE
      CHARACTER*92  FILEGG
      CHARACTER*1000 C360,ATLINE

      INTEGER       I,NSENS,NLVAR,LUNVAR,LINVAR,ISECT,NLOOP
      INTEGER       ERRNUM,PATHL
      REAL          FLAG,VAR

      PARAMETER (LUNVAR = 19)
      PARAMETER (ERRKEY = 'IPVAR ')
      PARAMETER (BLANK  = ' ')

      DATA NLVAR /0/

      PATHL  = INDEX (PATHGE,BLANK)

      IF (PATHL .LE. 1) THEN
         FILEGG = FILEG
       ELSE
         FILEGG = PATHGE(1:(PATHL-1)) // FILEG
      ENDIF
C-----------------------------------------------------------------------
C    Read Cultivar Specific Genetics/Cultivar Parameter File
C-----------------------------------------------------------------------
      OPEN (LUNVAR,FILE = FILEGG,STATUS = 'OLD',IOSTAT=ERRNUM)
      IF (ERRNUM .NE. 0) CALL ERROR (ERRKEY,ERRNUM,FILEG,0)
      IF (NSENS .EQ. 1) THEN
         I  = 1
         NLOOP = 0
         IF (INDEX('IE',RNMODE) .GT. 0) THEN
            CALL CLEAR
            WRITE (*,100)
         ENDIF
  200    CONTINUE
         CALL IGNORE (LUNVAR,LINVAR,ISECT,C360)
         IF (ISECT .EQ. 0) GO TO 211
         IF (ISECT .EQ. 2) GO TO 200
         IF (C360(1:1) .EQ. ' ' .OR. C360(1:1) .EQ. '*'
     &   .OR. C360(1:1) .EQ. '$') GO TO 200
         READ (C360, 110, IOSTAT=ERRNUM) VARTY,VRNAME,ECONO
         IF (ERRNUM .NE. 0) CALL ERROR (ERRKEY,ERRNUM,FILEG,LINVAR)
         IF (INDEX('IE',RNMODE) .GT. 0) THEN
            WRITE (*,120) I,VARTY,VRNAME,ECONO,ECONO(3:4)
         ENDIF
         IF (VARTY .EQ. VARNO) NLVAR = I
C
C        Write Pause Statement Every 15 lines
C
         IF (MOD(I,15) .EQ. 0 .AND. INDEX('IE',RNMODE) .GT. 0) THEN
            WRITE (*,300)
            READ  (5,'(A1)') ANS
         ENDIF
         I  = I + 1
         GOTO 200

  211    CONTINUE
         NLOOP = NLOOP + 1
         IF (NLOOP .GT. 25) CALL ERROR (ERRKEY,1,FILEG,LINVAR)
         LINE(1) = ' '
!!!         IF (INDEX('IE',RNMODE) .GT. 0) WRITE (*,350) NLVAR
         READ (5, 400) LINE
         CALL VERIFY (LINE,VAR,FLAG)
         IF (VAR .LE. 0) THEN
            VAR = NLVAR
          ELSE IF ((FLAG .GT. 0) .OR. (VAR .GT. (I-1))) THEN
            WRITE (*,500) I -1
            GO TO 211
          ELSE IF (VAR .NE. NINT(VAR)) THEN
            WRITE (*,510)
            GO TO 211
          ELSE IF (VAR .GT. 0) THEN
            NLVAR = NINT(VAR)
          ELSE
            GO TO 211
         ENDIF

         REWIND (LUNVAR)
      ENDIF

      I = 0

 2010 CONTINUE
      I = I + 1
 2000 CONTINUE
      CALL IGNORE (LUNVAR, LINVAR, ISECT, C360)
      IF (ISECT .EQ. 0) CALL ERROR (ERRKEY,2,FILEG,LINVAR)
      IF (ISECT .EQ. 2) GO TO 2000
      IF (C360(1:1) .EQ. ' ' .OR. C360(1:1) .EQ. '*') GO TO 2000

!     ------------------------------------------------------------------
      SELECT CASE (MODEL(1:5))

!     ** Formats now include space (6X) for quality parameter between
!     variety name and ecotype name

!     Generic SALUS simple crop models
!     09/21/2009 CHP/KAD
      CASE ('SALUS')
        READ (C360,'(6X,A6,1X,A16,7X,A)',IOSTAT=ERRNUM) VARTY,
     &         VRNAME, PLAINTXT
!     CROPGRO crops **
      CASE ('CRGRO','PRFRM')
        READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,CSDVAR,
     &       PPSEN,PH2T5,PHTHRS(6),PHTHRS(8),PHTHRS(10),PHTHRS(13),
     &       LFMAX,SLAVAR,SIZELF,XFRUIT,WTPSD,SFDUR,SDPDVR,PODUR,
     &       THRESH, SDPRO, SDLIP
        IF (LFMAX  .LE. 0) CALL ERROR (ERRKEY,22,FILEG,LINVAR)
        IF (SLAVAR .LE. 0) CALL ERROR (ERRKEY,23,FILEG,LINVAR)
        IF (SIZELF .LE. 0) CALL ERROR (ERRKEY,23,FILEG,LINVAR)
        IF (XFRUIT .LE. 0) CALL ERROR (ERRKEY,24,FILEG,LINVAR)
        IF (WTPSD  .LE. 0) CALL ERROR (ERRKEY,25,FILEG,LINVAR)
        IF (SDPDVR .LE. 0) CALL ERROR (ERRKEY,26,FILEG,LINVAR)
        IF (SFDUR  .LE. 0) CALL ERROR (ERRKEY,27,FILEG,LINVAR)
        IF (PODUR  .LE. 0) CALL ERROR (ERRKEY,28,FILEG,LINVAR)
        IF (THRESH .LE. 0) CALL ERROR (ERRKEY,50,FILEG,LINVAR)
!        IF (SDPRO  .LE. 0) CALL ERROR (ERRKEY,51,FILEG,LINVAR)
!        IF (SDLIP  .LE. 0) CALL ERROR (ERRKEY,52,FILEG,LINVAR)

C-GH Remove cassava
!     CropSim: wheat, barley
      CASE ('CSCRP')
!       For now, CropSim will just have a text string for cultivar info

!WHEAT & BARLEY
!@VAR#  VAR-NAME........  EXP#   ECO#  VREQ  PPS1    P8 G#WTS  GWTS SHWTS PHINT    P1    P2    P3    P4    P5    P6    P7  LA1S  LAFV  LAFR VBASE  VEFF  PPS2
!DFAULT DEFAULTS             . DFAULT     0     0   500    25    40   2.5    80   380    70   200   200    60    25   150   3.0   0.1   0.5     0     0     0

          READ (C360,810,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &      P1, P2, P3, P4, P5, P6, P7, P8, VREQ, VBASE, VEFF,
     &      PPS1, PPS2, PHINT, LA1S, LAFV, LAFR, SHWTS, GNOWT, GWTS,
     &      PLAINTXT

C-GH Tony update February, 2014
!     &      VREQ, PPS1, P8, GNOWT, GWTS, SHWTS, PHINT,
!     &      P1, P2, P3, P4, P5, P6, P7,
!     &      LA1S, LAFV, LAFR, VBASE, VEFF, PPS2, PLAINTXT

C-GH  Add cassava model
!     CASSAVA: cassava **
      CASE ('CSCAS')
          READ (C360,820,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &      PPS1, B01ND, B12ND, B23ND, B34ND, B45ND, B56ND,
C-GH &      SNFX, SRNWT, SRFR, HMPC, PHINT, LA1S, LAXS, LAXND, LAXN2,
     &      SRNWT, SRFR, HMPC, PHINT, LA1S, LAXS, LAXND, LAXN2,
     &      LAFS, LAFND, SLASS, LLIFA, LPEFR, STFR, PLAINTXT

C-LPM  Add CIAT cassava model
!     CASSAVA: cassava **
      CASE ('CSYCA')

!DA 04OCT2016 Removing LA1S variable, is not used according to LPM 07MAR15
!         READ (C360,821,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
!     &      PPS1, B01ND, B12ND, SRNWT, HMPC, LA1S, LAXS,
!     &      SLASS, LLIFA, LPEFR, LNSLP, NODWT, NODLT, PLAINTXT

          READ (C360,821,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &      PPS1, B01ND, B12ND, SRNWT, HMPC, LAXS,
     &      SLASS, LLIFA, LPEFR, LNSLP, NODWT, NODLT, PLAINTXT

!     Ceres-wheat: wheat, barley **
      CASE ('CSCER')
!       READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
!     &            P1V,P1D,P5,G1,G2,G3,PHINT, PLAINTXT
!       READ (C360,820,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO, PLAINTXT
       READ (C360, 830,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1V,P1D,P5,G1,G2,G3,PHINT, PLAINTXT

!     APSIM-NWheat wheat  **
      CASE ('WHAPS')
!*!        READ (C360,'(A6,1X,A16,7X,A6,6F6.0)',IOSTAT=ERRNUM)
        READ (C360,850,IOSTAT=ERRNUM)
     &            VARTY,VRNAME,ECONO,VSEN,PPSEN,P2,P5,PHINT,GRNO,MXFIL,
     &            STMMX,SLAP1,SLAP2,TC1P1,TC1P2,DTNP1,PLGP1,PLGP2,
     &            P2AF,P3AF,P4AF,P5AF,P6AF,
     &            ADLAI,ADTIL,ADPHO,STEMN,MXNUP,MXNCR,WFNU,
     &            PNUPR,EXNO3,MNNO3,EXNH4,MNNH4,INGWT,INGNC,FREAR,
     &            MNNCR,GPPSS,GPPES,MXGWT,MNRTN,NOMOB,RTDP1,RTDP2
!     Ceres Maize: maize, sweet corn **
      CASE ('MZCER','SWCER')
        READ (C360,'(A6,1X,A16,7X,A6,6F6.0)',IOSTAT=ERRNUM)
     &            VARTY,VRNAME,ECONO,P1,P2,P5,G2,G3,PHINT

!WDB 7/2016 Added cultivar coefficients for sugar beet model
      CASE ('BSCER')
          READ (C360,'(A6,1X,A16,7X,A6,9F6.0)',IOSTAT=ERRNUM)
     &        VARTY,VRNAME,ECONO,P1,P2,P5,G2,G3,PHYL1,PHYL2,FRSUG,DRCER
!WDB** end changes

!     Ixim maize **
      CASE ('MZIXM')
        READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1,P2,P5,G2,G3,PHINT,AX,LX
C ** Use default values if inputs not available
        LFN = ((1.4*P1)/(PHINT*0.5))+(10.55-0.0216*P1)
	IF (AX .EQ. 0.0) THEN
	  AX = 1000.0*EXP(-1.17 + (0.047*LFN))  !From Birch et al, 1998
	ENDIF
        IF (LX .EQ. 0.0) THEN
	  LX = 1.1138 * AX                      !From regression, JIL
	ENDIF

!     Ceres Sorghum **
      CASE ('SGCER')
        READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1,P2,P2O,P2R,PANTH,P3,P4,P5,PHINT,G1,G2
C-GH &            P1,P2O,P2R,P5,G1,G2,PHINT,P3,P4,P2,PANTH
C-GH &            P1,P2O,P2R,P5,G1,G2,PHINT,P3,P4
!           Read optional PBASE and PSAT parameters
!           If these parameters are non-zero, then optional
!             method is used
     &            ,PBASE, PSAT
!       Optional cultivar parameters
        IF (PBASE < 1.E-2) PBASE = -99.
        IF (PSAT  < 1.E-2) PSAT  = -99.

!     Ceres Millet **
      CASE ('MLCER')
        READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1,P2O,P2R,P5,G1,G4,PHINT,G0,G5
        IF (G4 > 1.2) THEN
          MSG(1)="G4 is fraction partitioning and should not exceed 1.2"
          MSG(2)=
     &  "G4 (from cultivar file) set equal to 1.2 for this simulation."
          CALL WARNING(2, ERRKEY, MSG)
          G4 = 1.2
        ENDIF

!     Substor Potato **
      CASE ('PTSUB')
        READ (C360, 800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            G2,G3,PD,P2,TC
!     &            G2,G3,G4,PD,P2,TC

!     Ceres Rice **
      CASE ('RICER')
        READ (C360,800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1,P2R,P5,P2O,G1,G2,G3,G4, PHINT,G5
!       For backwards compatibility for cultivar files with no G5.
        IF (ERRNUM /= 0) THEN
          READ (C360,800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &            P1,P2R,P5,P2O,G1,G2,G3,G4, PHINT
          G5 = 1.0
        ENDIF
        IF (G5 < 0.0) G5 = 1.0

!     ORYZA Rice **
!     Read name of OYRZA crop file
      CASE ('RIORZ')
        READ (C360,'(A6,1X,A16,7X,A80)',IOSTAT=ERRNUM) VARTY,VRNAME,
     &            PLAINTXT
        ECONO = '      '

!     CaneGro: South African Sugarcane model **
      CASE ('SCCAN')
        !WRITE(*, '(A)') C360
        READ (C360,1060,IOSTAT=ERRNUM) VARTY, VRNAME, ECONO,
     &      MaxPARCE, APFMX, STKPFMAX, SUCA, TBFT,
     &      LFMAX, MXLFAREA, MXLFARNO, PI1, PI2, PSWITCH, TTPLNTEM,
     &      TTRATNEM, CHUPIBASE, TT_POPGROWTH, POPTT16,
     &      TAR0, TDELAY, LER0, SER0, LG_AMBASE, AQP_UP5

! MJ removed 2018-02-08:
!            TBASE_GE_EM, TOPT_GE_EM, TFin_GE_EM, TBASE_LFEM,
!     &      TOPT_LFEM, TFinLFEM, TBASE_TLREM, TOPT_TLREM, TFin_TLREM,
!     &      TBASE_LFSEN, TOPT_LFSEN, TFin_LFSEN, TBASE_STKEX,
!     &      TOPT_STKEX,  TFin_STKEX,  TBASE_LFEX, TOPT_LFEX, TFin_LFEX,
!     &      TBASE_REX,  TOPT_REX, TFin_REX, TOPT_PHOT, TOPT_PHO2,
!     &      TFin_PHOT,  TBASE_RESP,   TOPT_RESP,   TFin_RESP,

        !WRITE(*, '(A, F10.5)') 'SER0 is ', SER0

!     Casupro: Florida-Colombia Sugarcane model **
      CASE ('SCCSP')
        READ (C360,1055,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &          LFMAX,PHTMAX,StkH2OFac,SuH2OFac,empty,PLF1,
     &          PLF2,Gamma,StkB,StkM,empty,
     &          SIZLF,LIsun,LIshd,empty,TB(1),TO1(1),TO2(1),TM(1),
     &          PI1,PI2,DTPI,LSFAC,empty,LI1,TELOM,TB(2),TO1(2),
     &          TO2(2),TM(2),Ph1P,Ph1R,Ph2,Ph3,Ph4,StkHrNO,RTNFAC,
     &          MinGr,empty,RES30C,RLF30C,R30C2,empty,empty

!     Taro, tanier **
      CASE ('TRARO','TNARO')
        READ (C360,800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &           P1,P3,P4,P5,G3,G4,PHINT,PCINT,PCGRD

!!     Sunflower **
!      CASE ('SUOIL')
!        READ (C360,800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
!     &           P1,P2,P5,G2,G3,O1
!
!     Pineapple **
      CASE ('PIALO')
        READ (C360,800,IOSTAT=ERRNUM) VARTY,VRNAME,ECONO,
     &           P1,P2,P3,P4,P5,P6,G2,G3,PHINT
      END SELECT

      IF (ERRNUM .NE. 0) CALL ERROR (ERRKEY,ERRNUM,FILEG,LINVAR)
      IF (((ADJUSTL(VARTY) .NE. ADJUSTL(VARNO)) .AND. (NSENS .EQ. 0))
     &       .OR. ((I .LT. NLVAR) .AND. (NSENS .EQ. 1))) GO TO 2010

      VARNO = VARTY
      CLOSE (LUNVAR)

      ! Added LAH Jan 1 2008
      OPEN (LUNVAR,FILE = FILEGG,STATUS = 'OLD',IOSTAT=ERRNUM)
      IF (ERRNUM .NE. 0) CALL ERROR (ERRKEY,ERRNUM,FILEG,0)
      DO I = 1, 100
        READ (LUNVAR,'(A)') C360
        IF (C360(1:1).EQ.'@') THEN
!         Skip the EXPNO column (CHP 1/29/2009)
!         ATLINE = C360(1:23) // C360(31:360)
          ATLINE = C360(1:23) // C360(31:1000)
          EXIT
        ENDIF
      ENDDO

      CLOSE (LUNVAR)

      RETURN

C-----------------------------------------------------------------------
C     Format Strings
C-----------------------------------------------------------------------

  100 FORMAT (T30,'VARIETY SELECTION',/,T30,'=================',
     &     //,T43,'ECOTYPE',2X,'MATURITY',
     &      /,2X,'NO.',1X,'ENTRY',3X,'VARIETY',22X,'GROUP',5X,'GROUP',
     &      /,2X,'---',1X,'------',2X,20('-'),8X,'-------',2X,
     &           '--------')
! 110 FORMAT (A6,1X,A16,1X,A6,6X,A2)
  110 FORMAT (A6,1X,A16,7X,A6)
  120 FORMAT (I4,') ',A6,2X,A16,13X,A6,6X,A2)
  300 FORMAT (/,'  More.... press < ENTER > key')
!!!  350 FORMAT (/,6X,'VARIETY SELECTED ===>',1X,I4,
!!!     &        /,6X,'NEW SELECTION ?  --->',3X,' ',$)
  400 FORMAT (80A1)
  500 FORMAT (6X,'ERROR! Variety Selection must be between 1 & ',I3,/)
  510 FORMAT (6X,'ERROR! Variety Selection must be an INTEGER value',/)

! 800 FORMAT (A6,1X,A16,1X,A6,15(F6.0))
  800 FORMAT (A6,1X,A16,7X,A6,21F6.0)                     !11/8/07

  810 FORMAT (A6,1X,A16,7X,A6,20F6.0,A)         !WHCRP, BACRP 03/16/2010
C 820 FORMAT (A6,1X,A16,7X,A6,22F6.0,A)         !CSCAS        04/25/2013
  820 FORMAT (A6,1X,A16,7X,A6,21F6.0,A)         !CSCAS        02/18/2014

!  821 FORMAT (A6,1X,A16,7X,A6,13F6.0,A)         !CSYCA        06/05/2015 !DA 04OCT2016 Changed since LA1S variable is removed, is not used according to LPM 07MAR15
  821 FORMAT (A6,1X,A16,7X,A6,12F6.0,A)         !CSYCA        06/05/2015

  830 FORMAT (A6,1X,A16,7X,A6,7F6.0,A)          !WHCER, BACER 03/16/2010
  850 FORMAT (A6,1X,A16,7X,A6,43F6.0,A)
! 1050 FORMAT (A6,1X,A16,7X,A6,9F6.0,1X,I5,3F6.0)          !11/8/07
 1055 FORMAT (A6,1X,A16,7X,A6,44F6.0)                   !02/10/2009
!!! 1055 FORMAT (A6,1X,A16,7X,A6,37F6.0,G8.0,4F6.1)       !02/10/2009
 ! 1060 FORMAT (A6,1X,A16,7X,A6,44F15.0)                   !02/10/2009
 1060 FORMAT (A6,1X,A16,7X,A6,22F15.0)                   !02/21/2018

!1500 FORMAT (A6,1X,A16,1X,A255)
 1500 FORMAT (A6,1X,A16,7X,A)                             !11/8/07

      END SUBROUTINE IPVAR

ext: for


text:
!==============================================================================!
  subroutine Save_Cgns_Results(grid, name_save)
!------------------------------------------------------------------------------!
!   Dummy function.                                                            !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Comm_Mod, only: this_proc
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type)  :: grid
  character(len=*) :: name_save
!==============================================================================!

  if (this_proc .lt. 2) print *, "# Code is not compiled with CGNS support"

  end subroutine

max_stars_repo_name: MassimoBorrelliPhysicist/T-Flows

max_issues_repo_name: MassimoBorrelliPhysicist/T-Flows

max_forks_repo_name: MassimoBorrelliPhysicist/T-Flows


text:
What is it?  The Physical Geography Research Group is a group of students (and hopefully one day faculty) who meet to discuss their research.  The members share an interest in physical and biogeography.

When did this start?  This group was started in conjunction with the Human Geography Research Group in winter quarter of 2006.  In the fall quarter of 2007, the groups were moved under the umbrella of GLOBAL, a UCD club.

Why bother?  The purpose of the group is for its members to help each other further their research by offering a venue to discuss researchrelated successes and troubles.  The idea is to help physical and biogeographers be successful in their research and help them navigate the university.  The students who come to these meetings tend to do well in terms of coursework and finding funding.  Is this because of the meetings themselves or do the meetings just draw good grad students?  Were not sure.  But if you come to a meeting, youre either a good student or you can learn from some.  Perhaps well leave this question for the Human Geography Research Group to answer.

More info:  Meetings are informal and often occur in the vicinity of coffee.  Dates and times for upcoming meetings are announced through GLOBAL.  People with an interest in physical and biogeography are encouraged to come and chat.  Formal discussion involving powerpoint presentations are prohibited except in the event that someone needs to practice a presentation for a conference.

Recent attendees have research interests in:
  birds
  mountain lions
  plants
  butterflies
  GIS
  remote sensing
  fire ecology
  watershed pollution modeling
  habitat modeling
  mountains
  beaches
  grasslands

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module advection_schemes

  implicit none

  contains

  ! ---------------------------------------------------------------------------
  !> Use a first-order centered advection scheme to calculate the advctive
  !! thickness tendency

  subroutine h_advec_1_centered(dhdt_advec, h, u, v, dx, dy, &
                                xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    ! dhdt is evaluated at the centre of the grid box
    double precision, intent(out) :: dhdt_advec(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: h(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: u(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: v(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: dx, dy
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer i, j, k

    dhdt_advec = 0d0

    do k = 1, layers
      do j = ylow-OL+1, yhigh+OL-1
        do i = xlow-OL+1, xhigh+OL-1
          dhdt_advec(i,j,k) = &
              - ((h(i,j,k)+h(i+1,j,k))*u(i+1,j,k) &
               - (h(i-1,j,k)+h(i,j,k))*u(i,j,k))/(dx*2d0) & ! d(hu)/dx
              - ((h(i,j,k)+h(i,j+1,k))*v(i,j+1,k) &
               - (h(i,j-1,k)+h(i,j,k))*v(i,j,k))/(dy*2d0)   ! d(hv)/dy
        end do
      end do
    end do

    return
  end subroutine h_advec_1_centered

  ! ---------------------------------------------------------------------------
  !> Use a first-order upwind advection scheme to calculate the advctive
  !! thickness tendency

  subroutine h_advec_1_upwind(dhdt_advec, h, u, v, dx, dy, &
                              xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    ! dhdt is evaluated at the centre of the grid box
    double precision, intent(out) :: dhdt_advec(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: h(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: u(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: v(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: dx, dy
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer i, j, k

    dhdt_advec = 0d0

    do k = 1, layers
      do j = ylow-OL+1, yhigh+OL-1
        do i = xlow-OL+1, xhigh+OL-1
          dhdt_advec(i,j,k) = &
              ! d(hu)/dx
              ! u(i+1,j,k) point
              - ( h(i+1,j,k)*(u(i+1,j,k) - abs(u(i+1,j,k)))/2d0 & ! u < 0
                + h(i,j,k)*(u(i+1,j,k)   + abs(u(i+1,j,k)))/2d0 & ! u > 0
                ! u(i,j,k) point
                - (h(i,j,k)*(u(i,j,k)   - abs(u(i,j,k)))/2d0 & ! u < 0
                  + h(i-1,j,k)*(u(i,j,k) + abs(u(i,j,k)))/2d0) & ! u > 0
                )/dx &

              ! d(hv)/dx
              ! v(i,j+1,k) point
              - ( h(i,j+1,k)*(v(i,j+1,k) - abs(v(i,j+1,k)))/2d0 & ! v < 0
                + h(i,j,k)*(v(i,j+1,k)   + abs(v(i,j+1,k)))/2d0 & ! v > 0
                ! v(i,j,k) point
                - ( h(i,j,k)*(v(i,j,k)   - abs(v(i,j,k)))/2d0 & ! v < 0
                  + h(i,j-1,k)*(v(i,j,k) + abs(v(i,j,k)))/2d0) & ! v > 0
                )/dy
        end do
      end do
    end do

    return
  end subroutine h_advec_1_upwind

end module advection_schemes

max_stars_repo_name: edoddridge/aronnax

max_issues_repo_name: edoddridge/aronnax

max_forks_repo_name: edoddridge/aronnax


text:
#include "stds.h"

#define ret_four() (4)

#define min(x,y) (x < y ? x : y)

int i = ret_four();

int main()
{
	printf("%d, %d\n", i, min(20, 10));
}

max_stars_repo_name: Byrd-Lin/Entr

max_issues_repo_name: Byrd-Lin/Entr

max_forks_repo_name: Byrd-Lin/Entr


text:
! { dg-do compile }
! Arguments to procedures with multiple entry points may be absent, however
! they are not optional, unless explicitly maked as such.
subroutine foo(i, a, b)
  logical a(2, 2)
  logical b(1)
  ! Check we don't get an "DIM must not be optional" error
  a = any(b, i)
entry bar()
end subroutine

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c  get_cft_name  --  FORTRAN-11 function
c
c  purpose:
c	read the title of a Critical Pair Fault Tree, the title
c	may be continued over MAX_NAME_LINES.
c
c  usage:
c	call get_cft_name( cft_name, nlines, nsubruns )
c
c  arguments:
c	cft_name - a MAX_SUBRUNS by MAX_NAME_LINES character*(MAX_TREE_STR)
c	           array which is to contain the title
c	nlines   - the number of lines the title occupies, integer*4
c	nsubruns - the subrun to which we are giving this title, integer*4
c
c  algoritm:
c	- include c3mdef.for
c	- initialize variables
c	- while ( continue ) do
c	    - read an input line
c	    - if continuation symbol is present then
c		- if name is full then return
c	    - else
c		- set no continue
c	    - end if
c	    - increment nlines
c	    - assign ibuff to name
c	- end do
c 	- return
c
c  history:
c	v1.1 created 22-mar-1985 by s.mcbride <rti>
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
	integer*4 function get_cft_name( cft_name, nlines, nsubruns )
	implicit none
c
c  parameter definitions
c
	character CONT_SYMB*2
	parameter ( CONT_SYMB = ' C' )		! continuation symbol

	include 'c3mdef.for'
c
c  arguments
c
	character*(MAX_TREE_STR) cft_name(MAX_NAME_LINES,MAX_SUBRUNS)
	integer*4 nlines
	integer*4 nsubruns
c
c  local variables
c
	character*(MAX_TREE_STR) ibuff		! input buffer from terminal

	integer*4 ilen				! length of ibuff

	logical*1 continue			! loop control variable
c
c  program logistics
c
	nlines = 0
	continue = 1

	do while ( continue )

	    read( unit=5, fmt=001 ) ilen, ibuff
001	    format( q, a )

	    call str$upcase( ibuff, ibuff )

	    if ( ibuff(ilen-1:ilen) .eq. CONT_SYMB ) then
		if ( nlines+1 .gt. MAX_NAME_LINES ) return
	    else
		continue = 0
	    end if

	    nlines = nlines + 1
	    cft_name(nlines,nsubruns) = ibuff(1:ilen)

	end do

	return
	end


text:
      SUBROUTINE SUREAD (IA,ND,NOUT,ITEST)
C
C     READS DATA FROM THE SOF INTO THE ARRAY IA.  ND IS AN INPUT
C     PARAMETER INDICATING THE NUMBER OF WORDS DESIRED.  ND=-1 MEANS
C     READ UNTIL END OF GROUP. NOUT IS AN OUTPUT PARAMETER INDICATING
C     THE NUMBER OF WORD THAT HAVE BEEN READ.  ITEST IS AN OUTPUT
C     PARAMETER WHERE ITEST=3 MEANS END OF ITEM ENCOUNTERED, ITEST=2
C     MEANS END OF GROUP ENCOUNTERED, AND ITEST=1 OTHERWISE.
C
      EXTERNAL        ANDF,RSHIFT
      INTEGER         ANDF,RSHIFT,BUF,BLKSIZ,DIRSIZ,IA(1),NMSBR(2)
      COMMON /MACHIN/ MACH,IHALF,JHALF
      COMMON /ZZZZZZ/ BUF(1)
      COMMON /SOF   / DITDUM(6),IO,IOPBN,IOLBN,IOMODE,IOPTR,IOSIND,
     1                IOITCD,IOBLK
      COMMON /SYS   / BLKSIZ,DIRSIZ
      DATA    IDLE  , IRD / 0,1    /
      DATA    IEOG  , IEOI/ 4H$EOG ,4H$EOI       /
      DATA    INDSBR/ 19  /, NMSBR /4HSURE,4HAD  /
C
      CALL CHKOPN (NMSBR(1))
      ICOUNT = 0
      IF (IOMODE .EQ. IRD) GO TO 20
      ITEST = 4
      NOUT  = 0
      RETURN
C
   10 ICOUNT = ICOUNT + 1
      IA(ICOUNT) = BUF(IOPTR)
      IOPTR = IOPTR + 1
      IF (ICOUNT .EQ. ND) GO TO 35
   20 IF (IOPTR .GT. BLKSIZ+IO) GO TO 80
C
C     READ SOF INTO ARRAY IA, BUT WATCH FOR END OF GROUP AND END OF ITEM
C
   30 IF (BUF(IOPTR) .EQ. IEOI) GO TO 50
      IF (BUF(IOPTR).EQ.IEOG .AND. ND.NE.-2) GO TO 40
      GO TO 10
C
C     READ THE REQUIRED NUMBER OF WORDS.
C
   35 ITEST = 1
      GO TO 70
C
C    REACHED END OF GROUP.
C
   40 ITEST = 2
      GO TO 60
C
C    REACHED END OF ITEM.
C
   50 ITEST  = 3
      IOMODE = IDLE
   60 IOPTR  = IOPTR + 1
   70 NOUT   = ICOUNT
      RETURN
C
C     REACHED END OF BLOCK.  REPLACE THE BLOCK CURRENTLY IN CORE BY ITS
C     LINK BLOCK.
C
   80 CALL FNXT (IOPBN,INXT)
      IF (MOD(IOPBN,2) .EQ. 1) GO TO 90
      NEXT = ANDF(RSHIFT(BUF(INXT),IHALF),JHALF)
      GO TO 100
   90 NEXT = ANDF(BUF(INXT),JHALF)
  100 IF (NEXT .EQ. 0) GO TO 510
      IOPBN = NEXT
      IOLBN = IOLBN + 1
      CALL SOFIO (IRD,IOPBN,BUF(IO-2))
      IOPTR = IO + 1
      GO TO 30
C
C     ERROR MESSAGES.
C
  510 CALL ERRMKN (INDSBR,9)
      RETURN
      END


text:
	SUBROUTINE GDWDSP  ( gdfile, gdtime, level, ivcord, wparm, wind,
     +			     garea, iscale, dmin, dmax, contin, iret )
C************************************************************************
C* GDWDSP								*
C*									*
C* This subroutine allows the user to accept parameters for the GDWIND	*
C* program.								*
C*									*
C* GDWDSP  ( GDFILE, GDTIME, LEVEL, IVCORD, WPARM, WIND, GAREA,		*
C*           ISCALE, DMIN, DMAX, CONTIN, IRET )				*
C*									*
C* Input parameters:							*
C*	GDFILE		CHAR*		Grid file			*
C*	GDTIME(2)	CHAR*		Grid time			*
C*	LEVEL(2)	INTEGER		Grid level			*
C*	IVCORD		INTEGER		Grid vertical coordinate	*
C*	WPARM		CHAR*		Vector name			*
C*	WIND		CHAR*		Wind type input by user		*
C*	GAREA		CHAR*		Graphics area			*
C*	ISCALE		INTEGER		Scaling factor			*
C*	DMIN		REAL		Minimum data value		*
C*	DMAX		REAL		Maximun data value		*
C*	CONTIN		LOGICAL		Flag for asking user to continue*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  3 = user entered "EXIT"	*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/85						*
C* S. Schotz/GSC	 6/90	Get respnd locally from IP_RESP		*
C* J. Whistler/SSAI	 4/91	Added iscale, dmin, and dmax		*
C* J. Whistler/SSAI	 6/91	Changed wording of MAX/MIN print out	*
C* S. Jacobs/NMC	 9/94	Changed format for scale		*
C* T. Lee/GSC		 7/01	Added contin				*
C************************************************************************
	CHARACTER*(*)	gdfile, gdtime(2), wparm, garea, wind
	INTEGER		level(2)
	LOGICAL		respnd, contin
C-----------------------------------------------------------------------
	iret = 0
	WRITE  ( 6, 1001 )
1001	FORMAT ( / ' PARAMETERS FOR GDWIND: ' / )
C
C*	Write out the grid file name.
C
	WRITE  ( 6, 1000 )  gdfile
1000	FORMAT ( / ' Grid file: ', A )
C
C*	Write out the grid identifier.
C
	WRITE  ( 6, 2000 )
2000	FORMAT ( ' GRID IDENTIFIER: ' )
	CALL GR_WTRM ( 6, .true., 0, gdtime, level, ivcord, wparm, ier )
C
C*	Write out the graphics area.
C
	WRITE  ( 6, 3000 ) garea, iscale, dmin, dmax
3000	FORMAT ( / ' GAREA:  ', A, / ' SCALE: ', I4, //
     +           'MINIMUM AND MAXIMUM VECTOR MAGNITUDE', 2F9.2 )
C
C*	Write out wind type.
C
	WRITE  ( 6, 3001 ) wind
3001	FORMAT ( / ' Wind type: ', A )
C
C*	If respond is set, wait for user to accept parameters.
C
	IF  ( contin )  THEN
	    CALL IP_RESP ( respnd, ier )
	    IF  ( respnd )  CALL TM_ACCP  ( ier )
	    IF  ( ier .eq. 2 )  iret = 3
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
program prog4
implicit none

complex :: cx

cx = cmplx(3d0,5d0)

write(*,*)cx

end program prog4

max_stars_repo_name: j-rheinheimer/Fisica-Computacional-I

max_issues_repo_name: j-rheinheimer/Fisica-Computacional-I

max_forks_repo_name: j-rheinheimer/Fisica-Computacional-I


text:
      MODULE GWFLPFMODULE

        public

        INTEGER, SAVE,   POINTER ::ILPFCB,IWDFLG,IWETIT,IHDWET
        INTEGER, SAVE,   POINTER ::ISFAC,ICONCV,ITHFLG,NOCVCO,NOVFC
        double precision,    SAVE,   POINTER ::WETFCT
        INTEGER, SAVE,   POINTER, DIMENSION(:)     ::LAYTYP
        INTEGER, SAVE,   POINTER, DIMENSION(:)     ::LAYAVG
        double precision,    SAVE,   POINTER, DIMENSION(:)     ::CHANI
        INTEGER, SAVE,   POINTER, DIMENSION(:)     ::LAYVKA
        INTEGER, SAVE,   POINTER, DIMENSION(:)     ::LAYWET
        INTEGER, SAVE,   POINTER, DIMENSION(:)     ::LAYSTRT
        INTEGER, SAVE,   POINTER, DIMENSION(:,:)   ::LAYFLG
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::VKA
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::VKCB
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::SC1
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::SC2
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::HANI
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::WETDRY
        double precision,    SAVE,   POINTER, DIMENSION(:,:,:) ::HK
      TYPE GWFLPFTYPE
        INTEGER, POINTER ::ILPFCB,IWDFLG,IWETIT,IHDWET
        INTEGER, POINTER ::ISFAC,ICONCV,ITHFLG,NOCVCO,NOVFC
        double precision, POINTER    ::WETFCT
        INTEGER,   POINTER, DIMENSION(:)     ::LAYTYP
        INTEGER,   POINTER, DIMENSION(:)     ::LAYAVG
        double precision,      POINTER, DIMENSION(:)     ::CHANI
        INTEGER,   POINTER, DIMENSION(:)     ::LAYVKA
        INTEGER,   POINTER, DIMENSION(:)     ::LAYWET
        INTEGER,   POINTER, DIMENSION(:)     ::LAYSTRT
        INTEGER,   POINTER, DIMENSION(:,:)   ::LAYFLG
        double precision,      POINTER, DIMENSION(:,:,:) ::VKA
        double precision,      POINTER, DIMENSION(:,:,:) ::VKCB
        double precision,      POINTER, DIMENSION(:,:,:) ::SC1
        double precision,      POINTER, DIMENSION(:,:,:) ::SC2
        double precision,      POINTER, DIMENSION(:,:,:) ::HANI
        double precision,      POINTER, DIMENSION(:,:,:) ::WETDRY
        double precision,      POINTER, DIMENSION(:,:,:) ::HK
      END TYPE
      TYPE(GWFLPFTYPE) GWFLPFDAT(10)

      contains

      SUBROUTINE GWF2LPF7DA(IGRID)
C  Deallocate LPF DATA
      !USE GWFLPFMODULE
C
        DEALLOCATE(GWFLPFDAT(IGRID)%ILPFCB)
        DEALLOCATE(GWFLPFDAT(IGRID)%IWDFLG)
        DEALLOCATE(GWFLPFDAT(IGRID)%IWETIT)
        DEALLOCATE(GWFLPFDAT(IGRID)%IHDWET)
        DEALLOCATE(GWFLPFDAT(IGRID)%ISFAC)
        DEALLOCATE(GWFLPFDAT(IGRID)%ICONCV)
        DEALLOCATE(GWFLPFDAT(IGRID)%ITHFLG)
        DEALLOCATE(GWFLPFDAT(IGRID)%NOCVCO)
        DEALLOCATE(GWFLPFDAT(IGRID)%NOVFC)
        DEALLOCATE(GWFLPFDAT(IGRID)%WETFCT)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYTYP)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYAVG)
        DEALLOCATE(GWFLPFDAT(IGRID)%CHANI)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYVKA)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYWET)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYSTRT)
        DEALLOCATE(GWFLPFDAT(IGRID)%LAYFLG)
        DEALLOCATE(GWFLPFDAT(IGRID)%VKA)
        DEALLOCATE(GWFLPFDAT(IGRID)%VKCB)
        DEALLOCATE(GWFLPFDAT(IGRID)%SC1)
        DEALLOCATE(GWFLPFDAT(IGRID)%SC2)
        DEALLOCATE(GWFLPFDAT(IGRID)%HANI)
        DEALLOCATE(GWFLPFDAT(IGRID)%WETDRY)
        DEALLOCATE(GWFLPFDAT(IGRID)%HK)
C
      RETURN
      END SUBROUTINE GWF2LPF7DA

!***********************************************************************

      SUBROUTINE SGWF2LPF7PNT(IGRID)
C  Point to LPF data for a grid.
      !USE GWFLPFMODULE
C
        ILPFCB=>GWFLPFDAT(IGRID)%ILPFCB
        IWDFLG=>GWFLPFDAT(IGRID)%IWDFLG
        IWETIT=>GWFLPFDAT(IGRID)%IWETIT
        IHDWET=>GWFLPFDAT(IGRID)%IHDWET
        ISFAC=>GWFLPFDAT(IGRID)%ISFAC
        ICONCV=>GWFLPFDAT(IGRID)%ICONCV
        ITHFLG=>GWFLPFDAT(IGRID)%ITHFLG
        NOCVCO=>GWFLPFDAT(IGRID)%NOCVCO
        NOVFC=>GWFLPFDAT(IGRID)%NOVFC
        WETFCT=>GWFLPFDAT(IGRID)%WETFCT
        LAYTYP=>GWFLPFDAT(IGRID)%LAYTYP
        LAYAVG=>GWFLPFDAT(IGRID)%LAYAVG
        CHANI=>GWFLPFDAT(IGRID)%CHANI
        LAYVKA=>GWFLPFDAT(IGRID)%LAYVKA
        LAYWET=>GWFLPFDAT(IGRID)%LAYWET
        LAYSTRT=>GWFLPFDAT(IGRID)%LAYSTRT
        LAYFLG=>GWFLPFDAT(IGRID)%LAYFLG
        VKA=>GWFLPFDAT(IGRID)%VKA
        VKCB=>GWFLPFDAT(IGRID)%VKCB
        SC1=>GWFLPFDAT(IGRID)%SC1
        SC2=>GWFLPFDAT(IGRID)%SC2
        HANI=>GWFLPFDAT(IGRID)%HANI
        WETDRY=>GWFLPFDAT(IGRID)%WETDRY
        HK=>GWFLPFDAT(IGRID)%HK
C
      RETURN
      END SUBROUTINE SGWF2LPF7PNT

!***********************************************************************

      SUBROUTINE GWF2LPF7PSV(IGRID)
C  Save LPF data for a grid.
      !USE GWFLPFMODULE
C
        GWFLPFDAT(IGRID)%ILPFCB=>ILPFCB
        GWFLPFDAT(IGRID)%IWDFLG=>IWDFLG
        GWFLPFDAT(IGRID)%IWETIT=>IWETIT
        GWFLPFDAT(IGRID)%IHDWET=>IHDWET
        GWFLPFDAT(IGRID)%ISFAC=>ISFAC
        GWFLPFDAT(IGRID)%ICONCV=>ICONCV
        GWFLPFDAT(IGRID)%ITHFLG=>ITHFLG
        GWFLPFDAT(IGRID)%NOCVCO=>NOCVCO
        GWFLPFDAT(IGRID)%NOVFC=>NOVFC
        GWFLPFDAT(IGRID)%WETFCT=>WETFCT
        GWFLPFDAT(IGRID)%LAYTYP=>LAYTYP
        GWFLPFDAT(IGRID)%LAYAVG=>LAYAVG
        GWFLPFDAT(IGRID)%CHANI=>CHANI
        GWFLPFDAT(IGRID)%LAYVKA=>LAYVKA
        GWFLPFDAT(IGRID)%LAYWET=>LAYWET
        GWFLPFDAT(IGRID)%LAYSTRT=>LAYSTRT
        GWFLPFDAT(IGRID)%LAYFLG=>LAYFLG
        GWFLPFDAT(IGRID)%VKA=>VKA
        GWFLPFDAT(IGRID)%VKCB=>VKCB
        GWFLPFDAT(IGRID)%SC1=>SC1
        GWFLPFDAT(IGRID)%SC2=>SC2
        GWFLPFDAT(IGRID)%HANI=>HANI
        GWFLPFDAT(IGRID)%WETDRY=>WETDRY
        GWFLPFDAT(IGRID)%HK=>HK
C
      RETURN
      END SUBROUTINE GWF2LPF7PSV

      END MODULE GWFLPFMODULE


text:
      FUNCTION f1dim(x)
      INTEGER NMAX
      REAL f1dim,func,x
      PARAMETER (NMAX=50)
CU    USES func
      INTEGER j,ncom
      REAL pcom(NMAX),xicom(NMAX),xt(NMAX)
      COMMON /f1com/ pcom,xicom,ncom
      do 11 j=1,ncom
        xt(j)=pcom(j)+x*xicom(j)
11    continue
      f1dim=func(xt)
      return
      END

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Functions/f1dim.for


text:
      SUBROUTINE DCONVO(ITYPE,BUFIN,NSAMPS,FILTER,NPTS,OBUF,NOUT)
c   Double Precision convo
C     CONVO PERFORMS TIME DOMAIN CONVOLUTION AND CORRELATION BETWEEN ARRAYS
C BUFIN AND FILTER.  THE OUTPUT IS RETURNED IN OBUF AND IS  VARIABLE IN LENGTH
C DEPENDING ON THE TYPE OF OPERATION REQUESTED.
C
C ARGUMENTS:
C        ITYPE  - TYPE OF CONVOLUTION OR CORRRELATION DESIGNATOR.
C               =-1,  FULL CONVOLUTION.  THE TIME REFERENCE OF THE FIRST OUTPUT
C                     POINT IS T1+T2, WHERE T1 IS THE TIME OF THE FIRST SAMPLE
C                     IN BUFIN AND T2 IS THE TIME OF THE FIRST SAMPLE IN ARRAY
C                     FILTER.  E.G.  IF A ZERO PHASE FILTER HAS TIME POINTS -19
C                     TO +19 AND THE FIRST SAMPLE IN BUFIN IS AT TIME 0, THEN
C                     THE TIME OF THE FIRST OUTPUT SAMPLE IS -19.
C               =+1,  FULL CORRELATION.  BOTH POSITIVE AND NEGATIVE LAGS ARE
C                     COMPUTED.  CORRELATIONS ARE EVEN FUNCTIONS, THEREFORE HALF
C                     CORRELATIONS GIVE THE SAME INFORMATION AND SHOULD BE USED
C                     MOST OF THE TIME.
C               =+2,  HALF CORRELATION.  ONLY THE RIGHT HALF OF THE CORRELATION
C                     IS PERFORMED..
C        BUFIN  - INPUT ARRAY TO BE FILTERED (CONVOLVED) OR CORRELATED.
C        NSAMPS - THE NUMBER OF SAMPLES IN BUFIN TO FILTER.
C        FILTER - AN ARRAY OF REAL FILTER WEIGHTS.  AN ARRAY OF VALUES TO BE
C                 CORRELATED.
C        MPTS   - THE NUMBER OF POINTS IN THE FILTER ARRAY.
C        OBUF   - THE OUTPUT ARRAY.
C        NOUT   - THE NUMBER OF OUTPUT SAMPLES TO GENERATE.  FOR CONVOLUTION
C                 THIS SHOULD NORMALLY BE MSAMPS+MPTS.  FOR CORRELATION THIS IS
C                 THE NUMBER OF LAGS TO OUTPUT, IT MIGHT BE  MIN0(MSAMPS,MPTS).
C
C   NOTE:  LEADING AND TRAILING ZEROES DO NOT HAVE TO BE GIVEN.
C
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, FEBRUARY 1979
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
      REAL*8 temp
      DIMENSION BUFIN(nsamps),FILTER(npts),OBUF(nout)
      NEXTM=1                                                           ! /* THE INDEX TO THE FIRST FILTER POINT
      I=0
      IF( IABS(ITYPE) .EQ. 1 ) THEN
C****
C****    DO THE FRONT TAPER IF A FULL CONVOLUTION/CORRELATION
C****
          M = NPTS - 1
          IF( ITYPE .LE. 0 ) THEN
              DO 50 N1 = 1, M                                           ! convolution
                 I = I + 1
                 TEMP = 0.
                 DO 40 N2 = 1, N1
                    TEMP = TEMP + BUFIN(N2) * FILTER(N1+1-N2)           ! /*  CONVOLUTION
   40            CONTINUE
                 obuf(i) = temp
   50         CONTINUE
          ELSE
              DO 70 N1 = 1, M                                               ! correlation
                 I = I + 1
                 TEMP = 0.
                 DO 60 N2 = 1, N1
                    TEMP = TEMP + BUFIN(N2) * FILTER(npts-n1-N2)
   60            CONTINUE
                 obuf(i) = temp
   70         CONTINUE
          ENDIF
      ENDIF
C****
C****  DO THE CONVOLUTION OR CORRELATION
C****
      I = I + 1
      JJ = 0
      IF( ITYPE .GE. 0 )THEN
          K = NPTS -1
          IF( ITYPE .EQ. 2 ) JJ = NPTS - 1
          INC = -1
      ELSE
          K = 0
          INC = 1
      ENDIF
      IF( inc .GT. 0 ) THEN
          DO 100 ii = i, nout
             J = K
             TEMP = 0.
             M = NEXTM
             jjj = ii + jj
             DO 90 j = k, npts - 1
                TEMP = TEMP + BUFIN(jjj-J) * FILTER(M)
                M = M + 1
   90        CONTINUE
             obuf(ii) = temp
             IF( ii .GE. nsamps) THEN
                 k = k + inc
                 nextm = nextm + 1
             ENDIF
  100     CONTINUE
      ELSE
          DO 150 ii = i, nout
             J = K
             TEMP = 0.
             M = NEXTM
             jjj = ii + jj
             DO 140 j = k, ii-1, inc
                TEMP = TEMP + BUFIN(jjj-J) * FILTER(M)
                M = M + 1
  140        CONTINUE
             obuf(ii) = temp
             IF( ii .GE. nsamps) THEN
                 k = k + inc
                 nextm = nextm + 1
             ENDIF
  150     CONTINUE
      ENDIF
      RETURN
      END

max_stars_repo_name: schwehr/sioseis

max_issues_repo_name: schwehr/sioseis

max_forks_repo_name: schwehr/sioseis


text:
      INCLUDE 'VICMAIN_FOR'

      SUBROUTINE MAIN44

      REAL*4 A(4,4), C(4,4)
      REAL*4 B(4), Z(4), D
      INTEGER*4 N

C     Initialize an array with a determinant of 1

      DATA A/5,7,6,5,  7,10,8,7,  6,8,10,9,  5,7,9,10/

C       INITIALIZE AN ARRAY TO COMPARE WITH THE 'C' VERSION

      C(1,1) = 6
      C(1,2) = 4
      C(1,3) = 6
      C(1,4) = 5

      C(2,1) = 7
      C(2,2) = 2
      C(2,3) = 3
      C(2,4) = 4

      C(3,1) = 4
      C(3,2) = 2
      C(3,3) = 1
      C(3,4) = 5

      C(4,1) = 6
      C(4,2) = 6
      C(4,3) = 6
      C(4,4) = 6

      N = 4
      CALL XVMESSAGE('FORTRAN TEST',' ')
      CALL XVMESSAGE('MATRIX WITH DETERMINANT = 1',' ')
      CALL TMINVMAT(A,N)
      CALL MINV(A,N,D,B,Z)
      CALL TMINVPRT (A,N,D)

      CALL XVMESSAGE('NOW INVERT BACK TO ORIGINAL',' ')
      CALL MINV(A,N,D,B,Z)
      CALL TMINVPRT (A,N,D)

      CALL XVMESSAGE('MATRIX FOR C BRIDGE COMPARE',' ')
      CALL TMINVMAT(C,N)
      CALL MINV(C,N,D,B,Z)
      CALL TMINVPRT (C,N,D)

      CALL XVMESSAGE('NOW INVERT BACK TO ORIGINAL',' ')
      CALL MINV(C,N,D,B,Z)
      CALL TMINVPRT (C,N,D)

      CALL XVMESSAGE('TEST THE C INTERFACE zminv',' ')
      CALL TZMINV

      RETURN
      END

C*******************************************************************C
C  THIS SUBROUTINE IS USED TO PRINT THE RESULTS OF THE TESTS.       C
C*******************************************************************C

      SUBROUTINE TMINVPRT (A,N,D)

      REAL*4 A(4,4), D
      INTEGER*4 N
      INTEGER*2 I, J
      CHARACTER*80 MSG

      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE('LOWER TRIANGLE OF INVERSE',' ')

      DO 340 I=1,N
         WRITE (MSG,99994) (A(I,J),J=1,I)
         CALL XVMESSAGE(MSG,' ')
  340 CONTINUE

      CALL XVMESSAGE(' ',' ')
      WRITE (MSG,99993) D
      CALL XVMESSAGE(MSG,' ')

99994 FORMAT (' ', 4F10.6)
99993 FORMAT ('VALUE OF DETERMINANT = ',F14.8)
      END
C*******************************************************************C
C  THIS SUBROUTINE IS USED TO PRINT THE MATRIX.			    C
C*******************************************************************C

      SUBROUTINE TMINVMAT (A,N)

      REAL*4 A(4,4)
      INTEGER*4 N
      INTEGER*2 I, J
      CHARACTER*80 MSG

      DO 540 I=1,N
         WRITE (MSG,99994) (A(I,J),J=1,N)
         CALL XVMESSAGE(MSG,' ')
  540 CONTINUE
      CALL XVMESSAGE(' ',' ')

99994 FORMAT (' ', 4F10.6)
      END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
module Mod_sld_calculateSigma
   use typre
   use Mod_sld_BaseElmope
   implicit none
   private
   public SetPointersCalculateSigma
   integer(ip), allocatable :: kfl_IsSet

contains

   !----------------------------------------------------------------------------
   !Setting Pointers
   subroutine SetPointersCalculateSigma(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

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

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

              !-------------------------------------------------------
              call ConcatenateProcedures(ProcHook%ResetArrays,ResetElemSigma)
              call ConcatenateProcedures(ProcHook%PreGauss,GaussResetSigma)

              if(a%kfl_printSigma) call ConcatenateProcedures(ProcHook%PrePostInterpolates,calculateGPStress)

              if(a%kfl_printGaussSigma) call ConcatenateProcedures(ProcHook%EndGauss,EndElmopeAssemblyGaussSigma_IRR)
              if(a%kfl_printNodalSigma) then
                  call ConcatenateProcedures(ProcHook%Initializations,ResetSigma)
                  call ConcatenateProcedures(ProcHook%ToLinearSystem,EndElmopeAssemblyToArraysSigma)
                  call ConcatenateProcedures(ProcHook%Finalizations,AssembleSigmaEndElmope)
                  call ConcatenateProcedures(ProcHook%PostInterpolates,EndElmopeSigmaGp2ElemArray)
              endif

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

      end select
   end subroutine

   !For actual computations
   !------------------------------------------------------
   subroutine ResetSigma
       implicit none

       a%sigma= 0.0_rp
   end subroutine ResetSigma

   subroutine ResetElemSigma
       implicit none

       elsigma   = 0.0_rp
   end subroutine ResetElemSigma

   subroutine GaussResetSigma
       implicit none

       gpsigma = 0.0_rp
   end subroutine GaussResetSigma

   subroutine EndElmopeAssemblyToArraysSigma
       implicit none
       integer(ip)::tn,nd

       call a%Mesh%GetNdime(nd)
       tn  = (nd*(nd+1))/2

       call a%Mesh%AssemblyToArray(e,tn,elsigma,a%sigma(:,:,1))

   end subroutine EndElmopeAssemblyToArraysSigma

   subroutine EndElmopeAssemblyGaussSigma_IRR
       implicit none
       integer(ip)::tn,nd

       a%sigma_g(ielem)%a(:,igaus) = gpsigma

   end subroutine EndElmopeAssemblyGaussSigma_IRR

   subroutine AssembleSigmaEndElmope
       implicit none
       integer(ip)::ipoin,tn,nd,np
       real(rp), pointer :: aux(:,:)

       call a%Mesh%GetNdime(nd)
       call a%Mesh%GetNpoin(np)
       tn  = (nd*(nd+1))/2

       do ipoin = 1,np
           if (vmass(ipoin) > 0.0_rp) then
               a%sigma(:,ipoin,1)    = a%sigma(:,ipoin,1)/vmass(ipoin)
           endif
       enddo

       aux => a%sigma(:,:,1)

       !call a%Mesh%ArrayCommunicator%GhostCommunicate(tn,a%sigma(:,:,1))
       call a%Mesh%ArrayCommunicator%GhostCommunicate(tn,aux)

       !Hanging nodes
       if (a%Mesh%kfl_HangingNodes .eqv. .true.) call a%Mesh%InterpolateHangingValues(tn,a%sigma(:,:,1))
       if (a%Mesh%kfl_perio == 1) call a%Mesh%MasterToSlave(tn,a%sigma(:,:,1))

   end subroutine AssembleSigmaEndElmope

   subroutine EndElmopeSigmaGp2ElemArray
       implicit none
       integer(ip)::tn,nd,np,idime,inode

       call a%Mesh%GetNdime(nd)
       call a%Mesh%GetNpoin(np)
       tn  = (nd*(nd+1))/2

       do inode = 1,e%pnode

           do idime=1,tn
               elsigma(idime,inode)    = elsigma(idime,inode)  + gpsigma(idime)*e%shape(inode,e%igaus)*dvol
           end do

       end do

   end subroutine EndElmopeSigmaGp2ElemArray

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:03 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE READ2D_NC__genmod
          INTERFACE
            SUBROUTINE READ2D_NC(FILEIN,VARNAME,XSIZE,YSIZE,ARRAYOUT)
              INTEGER(KIND=4), INTENT(IN) :: YSIZE
              INTEGER(KIND=4), INTENT(IN) :: XSIZE
              CHARACTER(*), INTENT(IN) :: FILEIN
              CHARACTER(*), INTENT(IN) :: VARNAME
              REAL(KIND=8), INTENT(OUT) :: ARRAYOUT(XSIZE,YSIZE)
            END SUBROUTINE READ2D_NC
          END INTERFACE
        END MODULE READ2D_NC__genmod


text:
! ###################################################################
! Copyright (c) 2013-2021, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################
module QCmodHDF

use local
use typedefs
use stringconstants
use ECPmod
use NameListTypedefs
use EBSDmod

contains
!--------------------------------------------------------------------------
!
! SUBROUTINE:ECPreadMCfile
!
!> @author Marc De Graef/Saransh Singh, Carnegie Mellon University
!
!> @brief read monte carlo file
!
!> @param enl ECP name list structure
!> @param acc energy structure
!
!> @date 02/07/18  SS 1.0 original
!--------------------------------------------------------------------------
recursive subroutine ECPreadQCMCMasterfile(enl,acc,master,efile,verbose)
!DEC$ ATTRIBUTES DLLEXPORT :: ECPreadQCMCMasterfile

use NameListTypedefs
use files
use io
use HDF5
use HDFsupport
use error
use ECPmod

IMPLICIT NONE

type(ECPNameListType),INTENT(INOUT)     :: enl
!f2py intent(in,out) ::  enl
type(ECPLargeAccumType),pointer         :: acc
type(ECPMasterType),pointer             :: master
character(fnlen),INTENT(IN),OPTIONAL    :: efile
logical,INTENT(IN),OPTIONAL             :: verbose

integer(kind=irg)                       :: istat, hdferr, nlines, nx
logical                                 :: stat, readonly
integer(HSIZE_T)                        :: dims3(3),dims4(4)
character(fnlen)                        :: groupname, dataset, energyfile
character(fnlen),allocatable            :: stringarray(:)

integer(kind=irg),allocatable           :: acc_z(:,:,:,:), acc_e(:,:,:)
real(kind=sgl),allocatable              :: srtmp(:,:,:)

type(HDFobjectStackType)                :: HDF_head

! is the efile parameter present? If so, use it as the filename, otherwise use the enl%energyfile parameter
if (PRESENT(efile)) then
  energyfile = efile
else
  energyfile = trim(EMsoft_getEMdatapathname())//trim(enl%energyfile)
end if
energyfile = EMsoft_toNativePath(energyfile)

allocate(acc)
allocate(master)

! first, we need to check whether or not the input file is of the HDF5 format type; if
! it is, we read it accordingly, otherwise we give error. Old format not supported anymore
!
call h5fis_hdf5_f(energyfile, stat, hdferr)

if (stat) then
  nullify(HDF_head%next)

! open the MC file using the default properties.
  readonly = .TRUE.
  hdferr =  HDF_openFile(energyfile, HDF_head, readonly)

! open the namelist group
groupname = SC_NMLparameters
  hdferr = HDF_openGroup(groupname, HDF_head)

groupname = SC_MCCLNameList
  hdferr = HDF_openGroup(groupname, HDF_head)

! read all the necessary variables from the namelist group
dataset = SC_xtalname
  call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
  enl%MCxtalname = trim(stringarray(1))
  deallocate(stringarray)

dataset = SC_mode
  call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
  enl%MCmode = trim(stringarray(1))
  deallocate(stringarray)

  if(enl%MCmode .ne. 'bse1') then
     call FatalError('ECPreadMCfile','This file is not bse1 mode. Please input correct HDF5 file')
  end if

dataset = SC_numsx
  call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%nsx)
  enl%nsx = (enl%nsx - 1)/2
  enl%nsy = enl%nsx

dataset = SC_EkeV
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%EkeV)

dataset = SC_Ehistmin
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%Ehistmin)

dataset = SC_Ebinsize
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%Ebinsize)

dataset = SC_depthmax
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%depthmax)

dataset = SC_depthstep
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%depthstep)

dataset = SC_sigstart
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MCsigstart)

dataset = SC_sigend
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MCsigend)

dataset = SC_sigstep
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MCsigstep)

dataset = SC_omega
  call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MComega)

! close the MCCL name list group
  call HDF_pop(HDF_head)
  !call HDF_pop(HDF_head)

! ECPQCMaster name list group will be read next
! open the namelist group
!groupname = SC_NMLparameters
!  hdferr = HDF_openGroup(groupname, HDF_head)

groupname = 'ECPQCMasterNameList'
  hdferr = HDF_openGroup(groupname, HDF_head)

! read all the necessary variables from the namelist group
dataset = SC_energyfile
  call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
  enl%Masterenergyfile = trim(stringarray(1))
  deallocate(stringarray)

dataset = SC_npx
  call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%npx)
  enl%npy = enl%npx

! close the name list
  call HDF_pop(HDF_head)
  call HDF_pop(HDF_head)
!
! read from the EMheader
groupname = SC_EMheader
  hdferr = HDF_openGroup(groupname, HDF_head)

groupname = SC_MCOpenCL
  hdferr = HDF_openGroup(groupname, HDF_head)

dataset = SC_ProgramName
  call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
  enl%MCprogname = trim(stringarray(1))
  deallocate(stringarray)

dataset = SC_Version
  call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
  enl%MCscversion = trim(stringarray(1))
  deallocate(stringarray)

  call HDF_pop(HDF_head)
  call HDF_pop(HDF_head)

! open the Data group
groupname = SC_EMData
  hdferr = HDF_openGroup(groupname, HDF_head)

groupname = SC_MCOpenCL
  hdferr = HDF_openGroup(groupname, HDF_head)

! read data items
dataset = SC_numangle
  call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numangle)

dataset = SC_numzbins
  call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numzbins)

dataset = SC_accumz
  call HDF_readDatasetIntegerArray4D(dataset, dims4, HDF_head, hdferr, acc_z)
  allocate(acc%accum_z(1:dims4(1),1:dims4(2),1:dims4(3),1:dims4(4)))
  acc%accum_z = acc_z
  deallocate(acc_z)

dataset = SC_accume
  call HDF_readDatasetIntegerArray3D(dataset, dims3, HDF_head, hdferr, acc_e)
  allocate(acc%accum_e(1:dims3(1),1:dims3(2),1:dims3(3)))
  acc%accum_e = acc_e
  deallocate(acc_e)

  enl%num_el = sum(acc%accum_z)

  call HDF_pop(HDF_head)
  !call HDF_pop(HDF_head)

!groupname = SC_EMData
!  hdferr = HDF_openGroup(groupname, HDF_head)

groupname = 'ECPQCmaster'
  hdferr = HDF_openGroup(groupname, HDF_head)

dataset = SC_numset
  call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numset)

dataset = SC_mLPNH
  call HDF_readDatasetFloatArray3D(dataset, dims3, HDF_head, hdferr, srtmp)
  allocate(master%mLPNH(-enl%npx:enl%npx,-enl%npy:enl%npy),stat=istat)
  master%mLPNH = sum(srtmp,3)
  deallocate(srtmp)

dataset = SC_mLPSH
  call HDF_readDatasetFloatArray3D(dataset, dims3, HDF_head, hdferr, srtmp)
  allocate(master%mLPSH(-enl%npx:enl%npx,-enl%npy:enl%npy),stat=istat)
  master%mLPSH = sum(srtmp,3)
  deallocate(srtmp)

! and close everything
  call HDF_pop(HDF_head,.TRUE.)
else
!==============================================
! OLD VERSION OF MC FILE NOT SUPPORTED ANYMORE
! COMMENTING OUT THE FOLLOWING LINES
! REPLACING WITH FATALERROR COMMENT
!==============================================

  call FatalError('ECPreadQCMCMasterfile','The file is not a h5 file. Old version of MC file not supported anymore!')
  !if (present(verbose)) call Message('opening '//trim(enl%energyfile), frm = "(A)")
end if

if (present(verbose)) then
    if (verbose) call Message(' -> completed reading '//trim(enl%energyfile), frm = "(A)")
end if

end subroutine ECPreadQCMCMasterfile

! !-------------------ROUTINE DISABLED FOR NOW UNTIL NEW EMEBSDQC PROGRAM IS READY
! !
! ! SUBROUTINE:EBSDQCreadMCMasterfile
! !
! !> @author Saransh Singh, Carnegie Mellon University
! !
! !> @brief read monte carlo file for EBSD QC master
! !
! !> @param enl EBSD name list structure
! !> @param acc energy structure
! !
! !> @date 02/07/18  SS 1.0 original
! !
! !> ROUTINE SCHEDULED TO BE REMOVED AND REPLACED BY NEW SEPARATED NAMELIST APPROACH [MDG, 4/4/18]
! !
! !--------------------------------------------------------------------------
! recursive subroutine EBSDQCreadMCMasterfile(enl, acc, master, efile, verbose)
! !DEC$ ATTRIBUTES DLLEXPORT :: EBSDQCreadMCMasterfile

! use io
! use HDF5
! use HDFsupport
! use error

! IMPLICIT NONE

! type(EBSDNameListType),INTENT(INOUT)      :: enl
!f2py intent(in,out) ::  enl
! type(EBSDAngleType),pointer               :: angles
! character(fnlen),INTENT(IN),OPTIONAL      :: efile
! logical,INTENT(IN),OPTIONAL               :: verbose

! type(EBSDLargeAccumType),pointer          :: acc
! type(EBSDMasterType),pointer              :: master

! integer(kind=irg)                         :: istat, hdferr, nlines, nx
! logical                                   :: stat, readonly, g_exists, FL
! integer(HSIZE_T)                          :: dims3(3), dims4(4), dims(1)

! character(fnlen)                          :: groupname, dataset, energyfile, masterfile, datagroupname
! character(fnlen),allocatable              :: stringarray(:)

! integer(kind=irg),allocatable             :: acc_e(:,:,:), acc_z(:,:,:,:)

! real(kind=sgl),allocatable                :: mLPNH(:,:,:)
! real(kind=sgl),allocatable                :: mLPSH(:,:,:)
! real(kind=sgl),allocatable                :: EkeVs(:)
! integer(kind=irg),allocatable             :: atomtype(:)

! real(kind=sgl),allocatable                :: srtmp(:,:,:,:)

! type(HDFobjectStackType)                  :: HDF_head

! ! is the efile parameter present? If so, use it as the filename, otherwise use the enl%energyfile parameter
! if (PRESENT(efile)) then
!   energyfile = efile
! else
!   energyfile = trim(EMsoft_getEMdatapathname())//trim(enl%energyfile)
! end if
! energyfile = EMsoft_toNativePath(energyfile)

! call h5fis_hdf5_f(energyfile, stat, hdferr)

! if (stat) then
! ! open the fortran HDF interface
!   call h5open_EMsoft(hdferr)

!   nullify(HDF_head%next)

! ! open the MC file using the default properties.
!   readonly = .TRUE.
!   hdferr =  HDF_openFile(energyfile, HDF_head, readonly)

! ! open the namelist group
! groupname = SC_NMLparameters
!   hdferr = HDF_openGroup(groupname, HDF_head)

! groupname = SC_MCCLNameList
!   hdferr = HDF_openGroup(groupname, HDF_head)

! ! read all the necessary variables from the namelist group
! dataset = SC_xtalname
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%MCxtalname = trim(stringarray(1))
!   deallocate(stringarray)

! dataset = SC_mode
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%MCmode = trim(stringarray(1))
!   deallocate(stringarray)

!   if (enl%MCmode .ne. 'full') call FatalError('EBSDQCreadMCMasterfile','File not in full mode. Please input correct HDF5 file')
! dataset = SC_numsx
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%nsx)
!   enl%nsx = (enl%nsx - 1)/2
!   enl%nsy = enl%nsx

! dataset = SC_EkeV
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%EkeV)

! dataset = SC_Ehistmin
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%Ehistmin)

! dataset = SC_Ebinsize
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%Ebinsize)

! dataset = SC_depthmax
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%depthmax)

! dataset = SC_depthstep
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%depthstep)

! dataset = SC_sig
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MCsig)

! dataset = SC_omega
!   call HDF_readDatasetDouble(dataset, HDF_head, hdferr, enl%MComega)

! ! close the name list group
!   call HDF_pop(HDF_head)

! groupname = SC_EBSDmasterNameList
!   hdferr = HDF_openGroup(groupname, HDF_head)

! dataset = SC_npx
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%npx)
!   enl%npy = enl%npx

!   call HDF_pop(HDF_head)
!   call HDF_pop(HDF_head)

! ! read from the EMheader
! groupname = SC_EMheader
!   hdferr = HDF_openGroup(groupname, HDF_head)

! ! next we need to make sure that this file has Monte Carlo data in it...
!   datagroupname = 'MCOpenCL'
!   call H5Lexists_f(HDF_head%next%objectID,trim(datagroupname),g_exists, hdferr)
!   if (.not.g_exists) then
!     call Message('This file does not appear to contain any Monte Carlo data or the file')
!     call Message('has the old data format; please use the EMmergeEBSD script to update')
!     call Message('the Monte Carlo data file to the correct format.  You will need to use')
!     call Message('the -C option to perform this update; consult the main EMsoft manual pages.')
!     call FatalError('EBSDQCreadMCMasterfile','This HDF file does not contain any Monte Carlo data')
!   end if
!   hdferr = HDF_openGroup(datagroupname, HDF_head)

! dataset = SC_ProgramName
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%MCprogname = trim(stringarray(1))
!   deallocate(stringarray)

! dataset = SC_Version
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%MCscversion = trim(stringarray(1))
!   deallocate(stringarray)

!   call HDF_pop(HDF_head)
!   call HDF_pop(HDF_head)

! ! open the Data group
! groupname = SC_EMData
!   hdferr = HDF_openGroup(groupname, HDF_head)
!   hdferr = HDF_openGroup(datagroupname, HDF_head)

! ! read data items
! dataset = SC_numEbins
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numEbins)

! dataset = SC_numzbins
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numzbins)

! dataset = SC_accume
!   call HDF_readDatasetIntegerArray3D(dataset, dims3, HDF_head, hdferr, acc_e)
!   enl%num_el = sum(acc_e)
!   nx = (dims3(2)-1)/2
!   allocate(acc%accum_e(1:dims3(1),-nx:nx,-nx:nx))
!   acc%accum_e = acc_e
!   deallocate(acc_e)

! dataset = SC_accumz
!   call HDF_readDatasetIntegerArray4D(dataset, dims4, HDF_head, hdferr, acc_z)
!   allocate(acc%accum_z(1:dims4(1),1:dims4(2),1:dims4(3),1:dims4(4)))
!   acc%accum_z = acc_z
!   deallocate(acc_z)

! ! and close everything
!   call HDF_pop(HDF_head)

! datagroupname = 'EBSDmaster'
! call H5Lexists_f(HDF_head%next%objectID,trim(datagroupname),g_exists, hdferr)
!   if (.not.g_exists) then
!     call Message('This file does not appear to contain any EBSD master data or the file')
!     call Message('has the old data format; please use the EMmergeEBSD script to update')
!     call Message('the master pattern data file to the correct format.  You will need to use')
!     call Message('the -M option to perform this update; consult the main EMsoft manual pages.')
!     call FatalError('EBSDQCreadMCMasterfile','This HDF file does not contain any Monte Carlo data')
!   end if
!   hdferr = HDF_openGroup(datagroupname, HDF_head)

! dataset = SC_numEbins
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%nE)
! ! make sure that MC and Master results are compatible
!   if ((enl%numEbins.ne.enl%nE).and.(.not.PRESENT(efile))) then
!     call Message('Energy histogram and Lambert stack have different energy dimension; aborting program', frm = "(A)")
!     call HDF_pop(HDF_head,.TRUE.)
!     stop
!   end if

! dataset = SC_numset
!   call HDF_readDatasetInteger(dataset, HDF_head, hdferr, enl%numset)

! ! dataset = 'squhex'
! ! call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
! ! enl%sqorhe = trim(stringarray(1))
! ! deallocate(stringarray)

! dataset = SC_mLPNH
!   call HDF_readDatasetFloatArray4D(dataset, dims4, HDF_head, hdferr, srtmp)
!   allocate(master%mLPNH(-enl%npx:enl%npx,-enl%npy:enl%npy,enl%nE),stat=istat)
!   master%mLPNH = sum(srtmp,4)
!   deallocate(srtmp)

! dataset = SC_mLPSH
!   call HDF_readDatasetFloatArray4D(dataset, dims4, HDF_head, hdferr, srtmp)
!   allocate(master%mLPSH(-enl%npx:enl%npx,-enl%npy:enl%npy,enl%nE),stat=istat)
!   master%mLPSH = sum(srtmp,4)
!   deallocate(srtmp)

!   call HDF_pop(HDF_head)
!   call HDF_pop(HDF_head)

! groupname = SC_EMheader
!   hdferr = HDF_openGroup(groupname, HDF_head)
!   hdferr = HDF_openGroup(datagroupname, HDF_head)

! dataset = SC_ProgramName
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%Masterprogname = trim(stringarray(1))
!   deallocate(stringarray)

! dataset = SC_Version
!   call HDF_readDatasetStringArray(dataset, nlines, HDF_head, hdferr, stringarray)
!   enl%Masterscversion = trim(stringarray(1))
!   deallocate(stringarray)

!   call HDF_pop(HDF_head,.TRUE.)

! ! close the fortran HDF interface
!   call h5close_EMsoft(hdferr)

! else
!   call FatalError('EBSDQCreadMCMasterfile','MC file not found')
! end if

! if (present(verbose)) call Message(' -> completed reading Monte Carlo and Master data from '//trim(enl%energyfile), frm = "(A)")

! end subroutine EBSDQCreadMCMasterfile

end module

max_stars_repo_name: josephtessmer/EMsoft

max_stars_repo_licenses: Intel Unlicense MIT-CMU BSD-3-Clause

max_issues_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense

max_forks_repo_licenses: Intel BSD-3-Clause MIT-CMU Unlicense


! { dg-do compile }
!
! PR fortran/49690
!
! Reduced test case, based on the one of Debian bug #631204
!

subroutine ctrlc_ast
   common /xinterrupt/ interrupted
   logical interrupted
   interrupted = .true.
end subroutine ctrlc_ast

subroutine set_ctrl_c(ctrlc_ast)
   external ctrlc_ast
   intrinsic signal
   integer old_handle
   common /xinterrupt/ interrupted
   logical interrupted
   old_handler = signal(2, ctrlc_ast)
end subroutine set_ctrl_c


text:
c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   utilities for normalisation of time series
c   author T. Schreiber (1998)
c===========================================================================
      subroutine rms(nmax,x,sc,sd)
c  return mean sc and rms amplitude sd
      dimension x(nmax)

      sc=0.
      do 10 n=1,nmax
 10      sc=sc+x(n)
      sc=sc/nmax
      sd=0.
      do 20 n=1,nmax
 20      sd=sd+(x(n)-sc)**2
      sd=sqrt(sd/nmax)
      end

      subroutine normal(nmax,x,sc,sd)
c  subtract mean, return mean sc and rms amplitude sd
      dimension x(nmax)

      call rms(nmax,x,sc,sd)
      do 10 n=1,nmax
 10      x(n)=x(n)-sc
      end

      subroutine normal1(nmax,x,sc,sd)
c  subtract mean, rescale to unit variance,
c  return mean sc and rms amplitude sd
      dimension x(nmax)

      call rms(nmax,x,sc,sd)
      if(sd.eq.0.) stop
     .   "normal1: zero variance, cannot normalise"
      do 10 n=1,nmax
 10      x(n)=(x(n)-sc)/sd
      end

      subroutine minmax(nmax,x,xmin,xmax)
c  obtain smallest and  largest value in x
      dimension x(nmax)

      xmin=x(1)
      xmax=x(1)
      do 10 n=2,nmax
         xmin=min(x(n),xmin)
 10      xmax=max(x(n),xmax)
      end

max_stars_repo_name: homiak/jabaws

max_issues_repo_name: homiak/jabaws

max_forks_repo_name: homiak/jabaws


text:
C
C	$Id: gdawk.f,v 1.8 2008-07-27 00:20:57 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE GDAWK(WKID)
C
      INTEGER WKID
C
      CALL GZDAWK(WKID)
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


subroutine get_unit ( iunit )

!*****************************************************************************80
!
!! GET_UNIT returns a free FORTRAN unit number.
!
!  Discussion:
!
!    A "free" FORTRAN unit number is an integer between 1 and 99 which
!    is not currently associated with an I/O device.  A free FORTRAN unit
!    number is needed in order to open a file with the OPEN command.
!
!    If IUNIT = 0, then no free FORTRAN unit could be found, although
!    all 99 units were checked (except for units 5, 6 and 9, which
!    are commonly reserved for console I/O).
!
!    Otherwise, IUNIT is an integer between 1 and 99, representing a
!    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
!    are special, and will never return those values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 September 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer IUNIT, the free unit number.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) ios
  integer ( kind = 4 ) iunit
  logical ( kind = 4 ) lopen

  iunit = 0

  do i = 1, 99

    if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then

      inquire ( unit = i, opened = lopen, iostat = ios )

      if ( ios == 0 ) then
        if ( .not. lopen ) then
          iunit = i
          return
        end if
      end if

    end if

  end do

  return
end


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 02.01.02.01/02                        *
C  *    TEST TITLE : Structure deletion with an open       *
C  *                 structure                             *
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

C parameter type for structure state

      INTEGER POPNST, PSEMPT
      PARAMETER (POPNST = 1, PSEMPT = 1)

C PHIGS parameter types
      INTEGER DELSTR, STYPE, STRID, STRSTI

      LOGICAL CSSEQ

      CALL INITGL ('02.01.02.01/02')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

C creation of structure network
      CALL POPST (100)
      CALL PEXST (105)
      CALL PEXST (110)
      CALL PCLST
      CALL POPST (110)
      CALL PEXST (115)
      CALL PEXST (120)
      CALL PCLST

      CALL SETMSG ('5', 'Deleting an open root structure should '   //
     1             'cause the structure to exist in the CSS as an ' //
     2             'open structure.')

      DELSTR = 100
      CALL POPST (DELSTR)
      CALL PDST (DELSTR)

C use <inquire open structure> to determine
C    stype = structure status
C    strid = structure id

      CALL PQOPST (ERRIND, STYPE, STRID)
      CALL CHKINQ ('pqopst', ERRIND)
      IF (STYPE .NE. POPNST .OR.
     1    STRID .NE. DELSTR)   THEN
         CALL FAIL
      ELSE
         CALL PASS
         CALL PCLST
      ENDIF

      CALL SETMSG ('5', 'Deleting an open root structure should ' //
     1             'cause the structure to exist in the CSS as '  //
     2             'an empty structure.')

C strsti = structure status identifier
      CALL PQSTST (DELSTR, ERRIND, STRSTI)
      CALL CHKINQ ('pqstst', ERRIND)
      CALL IFPF   (STRSTI .EQ. PSEMPT)

      CALL SETMSG ('2', 'Deleting an open root structure should '  //
     1             'cause the deletion of all references made to ' //
     2             'that structure contained in other structures.')

      CALL IFPF (CSSEQ ('110,1, 115,0/ '//
     1                  '110,2, 120,0/ '//
     2                  '100,0/ '       //
     3                  '105,0/ '))

      CALL SETMSG ('5', 'Deleting a non-root structure should '  //
     1             'cause the structure to exist in the CSS as ' //
     2             'an open structure.')

      DELSTR = 115
      CALL POPST (DELSTR)
      CALL PDST (DELSTR)

C use <inquire open structure> to determine
C    stype = structure status
C    strid = structure id

      CALL PQOPST (ERRIND, STYPE, STRID)
      CALL CHKINQ ('pqopst', ERRIND)
      IF (STYPE .NE. POPNST   .OR.
     1    STRID .NE. DELSTR)     THEN
         CALL FAIL
      ELSE
         CALL PASS
         CALL PCLST
      ENDIF

      CALL SETMSG ('5', 'Deleting a non-root structure should '  //
     1             'cause the structure to exist in the CSS as ' //
     2             'an empty structure.')

C strsti = structure status identifier
      CALL PQSTST (DELSTR, ERRIND, STRSTI)
      CALL CHKINQ ('pqstst', ERRIND)
      CALL IFPF   (STRSTI .EQ. PSEMPT)

      CALL SETMSG ('2', 'Deleting a non-root structure should '    //
     1             'cause the deletion of all references made to ' //
     2             'that structure contained in other '            //
     3             'structures.')

      CALL IFPF (CSSEQ ('110,1, 120,0/' //
     1                  '115,0/ '       //
     2                  '105,0/ '       //
     3                  '100,0/ '))

 666  CONTINUE
      CALL ENDIT
      END


text:
!! R310 defined-operator
!    is defined-unary-op        R703
!    or defined-binary-op       R723
!    or extended-intrinsic-op   R311

interface operator(.unaryop.)
end interface operator(.unaryop.)
interface operator(.binaryop.)
end interface operator(.binaryop.)
interface operator(**)
end interface operator(**)
interface operator(//)
end interface operator(//)
end

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


text:
      INTEGER FUNCTION  IBITS(IW,IBIT,NBITS)
      IX=0
      DO 10 I=0,NBITS-1
      IX=IBSET(IX,I)
10    CONTINUE
      IY=ISHFT(IW,-IBIT)
      IBITS=IAND(IX,IY)
      RETURN
C
C
      END

max_stars_repo_name: HydrologicEngineeringCenter/heclib

max_issues_repo_name: HydrologicEngineeringCenter/heclib

max_forks_repo_name: HydrologicEngineeringCenter/heclib


Module numbers_module

  Implicit None

  Integer, Parameter, Public :: wp = Selected_real_kind( 12, 70 )

  Private

End Module numbers_module


text:
C    @(#)find_del.f	20.3 2/13/96
        integer function find_del (record)
        character record *(*)

c       This function searches delete(*) for record.

        include 'ipfinc/parametr.inc'
        include 'ipfinc/delete.inc'

        logical found

        i1 = 1
        i2 = ndelete
        found = .false.
c
c       This routine exploits komp_del by temporarily installing
c       the searched record in delete(ndelete+1)
c
        delete(ndelete+1) = record

        do while (i1 .le. i2 .and. .not. found)
           ix = (i1 + i2) / 2
           komp = komp_del (ix, ndelete+1)
           if (komp .lt. 0) then
              i1 = ix + 1
           else if (komp .gt. 0) then
              i2 = ix - 1
           else
              found = .true.
              find_del = ix
           endif
        enddo
        if (.not. found) then
           find_del = -ix
        else if (delete(ix)(3:3) .eq. '*') then
           find_del = -ix
        endif
        return
        end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
      MODULE MOD_HMINUS

      CONTAINS

      SUBROUTINE runSUB(CMD,JOB, timer, reset)
      use MOD_WRSTART
      use MOD_STEAL
      use MOD_WRCONT
      use MOD_COMO
      use MOD_ETL
      character*(*) :: CMD
      character*7 :: JOB
      integer :: timer
      logical,optional:: reset
      print *,'HMINUS: Call '//CMD
      selectcase(CMD)
        case('WRSTART'); call WRSTART
        case('WRCONT');  call WRCONT (JOB)
        case('STEAL');   call STEAL  (JOB)
        case('ETL');     call ETL    (JOB)
        case('COMO');    call COMO
        case default
        print *,'HMINUS: Unknwon CMD:"'//CMD//'"'
        STOP 'HMINUS: Unknwon CMD'
      endselect
      call finish(CMD,timer,reset)
      END SUBROUTINE

      SUBROUTINE HMINUS_LTE

      use MOD_TICTOC
      use UTILS,only: cp
      use PARAMS_ARRAY

      USE FILE_OPERATIONS

      IMPLICIT NONE

      integer ipdim,    nbdim, itemp
      integer itsw
      integer lblaon,   inew,   ipmax,   nbmax
      integer timer,timer2
      integer nbinw, it
      real*8  almin, almax
      real*8  scaevt, absevt, scafac, absfac, scagri

      parameter (IPDIM=25,NBDIM=99)
      COMMON /LIBLDAT/ SCAGRI(IPDIM), SCAEVT(IPDIM,NBDIM),
     $                                ABSEVT(IPDIM,NBDIM)
      COMMON /LIBLPAR/ ALMIN, ALMAX, LBLAON, IPMAX, NBMAX, NBINW
      COMMON /LIBLFAC/ SCAFAC(NDDIM,NFDIM),ABSFAC(NDDIM,NFDIM)
      character*7 :: JOB

      CALL SYSTEM("echo '\n'START OF LTE RUN - $(date)'\n'")

      CALL SYSTEM("echo DIRECTORY: $(pwd)'\n'")

      CALL RM_FILE(NTP_FILE, '-vf')
      CALL RM_FILE(NTW_FILE, '-vf')

      itsw=0
      itemp=0
      ALMIN=0.    !***  default values for lineblanketing
      ALMAX=0.
      LBLAON=0

      call TIC(timer)
      call TIC()
      rewind(99); write(99,'(A7)'),'wrstart'; JOB='WRSTART'
      PRINT *,' WIND STARTED: JOB=',JOB,'  tstart= ',0
      call tic(timer2)
      call runSUB('WRSTART',JOB, timer2)
      CALL runSUB('STEAL',JOB, timer2)
      CALL runSUB('WRCONT',JOB, timer2)
      itemp=itemp+1
      if (itemp.ge.2) itsw=1

   10 continue
      IF (JOB.EQ.'newline') INEW=1
      if (itsw.eq.1) itsw=0
      print *,'HMINUS: CYCLE STARTED'
      call tic(timer2)
      call runSUB('COMO', JOB, timer2)
      call runSUB('ETL',  JOB, timer2)
      print *,'HMINUS: TIME USED FOR CYCLE: '//writeTOC(timer2)
      IF (INEW.EQ.1) THEN
        print *,'HMINUS: TIME FOR CYCLE INCLUDING LINE BACKGROUND '//
     &              'RADIATION FIELD, JOB='//JOB
        INEW=0
        ENDIF
      selectcase(JOB)
        case('wrcont','extrap') ; call runSUB('wrcont',JOB,timer2)
        case('repeat')          ; goto 10;
      endselect
      PRINT *,'HMINUS: NO NEW JOB TO BE ROUTED; JOB=',JOB
      REWIND 99; WRITE (99,'(A4)') 'exit'

      print *,'HMINUS: Elapsed time for total job: '//writeTOC(timer)

      CALL SYSTEM("echo '\n'END OF LTE RUN - $(date)'\n'")

      END SUBROUTINE

      SUBROUTINE FINISH(PROG,timer,reset)
      USE MOD_TICTOC
      USE UTILS
      IMPLICIT NONE
      character :: PROG*(*)
      character :: P2*20
      integer   :: timer
      logical,optional :: reset
      integer,save :: counter = 1
      P2=PROG
      print *,'HMINUS-Finish: '//trim(P2)
     &  //'('//trim(adjustl(int2str(counter)))//')'
     &  //', time: '//trim(adjustl(writeTOC(timer)))
     &  //', total: '//trim(adjustl(writeTOC()))
      if(present(reset).and.reset) call tic(timer)
      counter=counter+1

      END SUBROUTINE

      END MODULE

      PROGRAM HMINUS

      use MOD_WRSTART
      use MOD_STEAL
      use MOD_WRCONT
      use MOD_COMO
      use MOD_ETL
      use MOD_TICTOC
      use UTILS, only: cp
      use MOD_HMINUS
      use PARAMS_ARRAY

      use common_block
      use file_operations

      implicit none

      integer ipdim,  nbdim, itemp
      integer itsw
      integer lblaon, inew, ipmax, nbmax
      integer timer,timer2
      integer nbinw
      real*8  almin, almax
      real*8  scaevt, absevt, scafac, absfac, scagri

      real*8 :: cycle_start, cycle_finish

      parameter(IPDIM = 25, NBDIM = 99)
      COMMON /LIBLDAT/ SCAGRI(IPDIM), SCAEVT(IPDIM, NBDIM), ABSEVT(IPDIM,NBDIM)
      COMMON /LIBLPAR/ ALMIN, ALMAX, LBLAON, IPMAX, NBMAX, NBINW

      COMMON /LIBLFAC/ SCAFAC(NDDIM, NFDIM),ABSFAC(NDDIM, NFDIM)

      character*7 :: JOB

      LOGICAL :: VEL_FIELD_FILE_EXISTS

      LTE_RUN =             .FALSE.
      VEL_FIELD_FROM_FILE = .FALSE.

      INQUIRE(FILE = VEL_FIELD_FILE, EXIST = VEL_FIELD_FILE_EXISTS)

      IF (VEL_FIELD_FILE_EXISTS) THEN

         VEL_FIELD_FROM_FILE = .TRUE.

         WRITE(*, '(A,1x,A,A,/)') 'Attention: the velocity field will be taken from the file', VEL_FIELD_FILE, '!'

      ENDIF

      itsw=0
      itemp=0
      ALMIN=0.    !***  default values for lineblanketing
      ALMAX=0.
      LBLAON=0

      call TIC(timer)
      call TIC()

  100 CONTINUE

      REWIND 99; READ (99,'(A7)') JOB

      WRITE(*, '(A,A)') 'JOB = ', JOB

      SELECTCASE(JOB)

        CASE('tmpcor');            GOTO 1
        CASE('wrcont');            GOTO 1
        CASE('repeat', 'newline'); GOTO 10
        CASE('wrstart');           CONTINUE
        CASE('lte')

             CALL HMINUS_LTE(); STOP

      CASE DEFAULT

          PRINT *,' OPTION NOT KNOWN; JOB=',JOB
          REWIND 99; WRITE (99,'(A4)') 'abort'
          PRINT *,' Elapsed time for total wind-job:',toc(timer),' sec'
          STOP 'ABORT'

      ENDSELECT

      CALL SYSTEM("echo '\n'START OF THE RUN - $(date)'\n'")

      CALL SYSTEM("echo DIRECTORY: $(pwd)'\n'")

      CALL tic(timer2)

      CALL RM_FILE('BROYDEN',         '-vf')
      CALL RM_FILE('NEWBROYDEN',      '-vf')

      CALL RM_FILE('wall_time.como',   '-vf')
      CALL RM_FILE('wall_time.etl',    '-vf')
      CALL RM_FILE('wall_time.steal',  '-vf')
      CALL RM_FILE('wall_time.cycle',  '-vf')
      CALL RM_FILE('wall_time.linpop', '-vf')
      CALL RM_FILE('wall_time.wrcont', '-vf')

      CALL RM_FILE('cpu_time.como',    '-vf')
      CALL RM_FILE('cpu_time.etl',     '-vf')
      CALL RM_FILE('cpu_time.steal',   '-vf')
      CALL RM_FILE('cpu_time.cycle',   '-vf')
      CALL RM_FILE('cpu_time.linpop',  '-vf')
      CALL RM_FILE('cpu_time.wrcont',  '-vf')

      CALL WRSTART;    call finish('WRSTART', timer2, .true.)

      CALL STEAL(JOB); call finish('STEAL', timer2)

      IF (JOB .NE. 'wrcont') THEN
        PRINT *,'HMINUS: NO NEW JOB TO BE ROUTED; JOB=', JOB
        REWIND 99
        WRITE (99,'(A4)') 'exit'

        print *,' Elapsed time for total wind-job:',toc(timer),' sec'
        STOP 'EXIT'
      ENDIF

    1 continue

      call tic(timer2)

      CALL WRCONT(JOB)

      itemp = itemp + 1

      if (itemp .ge. 2) itsw = 1

      call finish('WRCONT', timer2)

      IF (JOB.NE.'repeat'.AND.JOB.NE.'newline') THEN
         PRINT *,' NO NEW JOB TO BE ROUTED; JOB=',JOB
         REWIND 99
         WRITE (99,'(A4)') 'exit'
         print *,'HMINUS: Elapsed time for total wind-job:', toc(timer), ' sec'
         STOP 'EXIT'
      ENDIF

   10 continue

      IF (JOB .EQ. 'newline') INEW = 1

      if (itsw .eq. 1) itsw = 0

      print*, 'HMINUS: CYCLE STARTED'

      call cpu_time(cycle_start); call system("echo -n $(date +%s) >> wall_time.cycle")

      call tic(timer2)

      call COMO; call finish('COMO', timer2)

      call ETL(JOB); call finish('ETL', timer2)

      call STEAL(JOB); call finish('STEAL', timer2)

      call system("echo ' '$(date +%s) >> wall_time.cycle"); call cpu_time(cycle_finish)

      call open_to_append(231, 'cpu_time.cycle'); write(231, '(F6.3)') cycle_finish - cycle_start; close(231)

      print*, 'HMINUS: TIME USED FOR CYCLE: '//writeTOC(timer2)

      IF (INEW.EQ.1) THEN
        print *,'HMINUS: TIME FOR CYCLE INCLUDING LINE BACKGROUND '//
     &              'RADIATION FIELD, JOB='//JOB
        INEW=0
        ENDIF
      selectcase(JOB)
        case('wrcont','extrap') ; goto 1;
        case('repeat')          ; goto 10;
      endselect

      call WRCONT(JOB); call finish('WRCONT',timer2)

      PRINT *,'HMINUS: NO NEW JOB TO BE ROUTED; JOB=',JOB
      REWIND 99
      WRITE (99,'(A4)') 'exit'
      print *,'HMINUS: Elapsed time for total job: '//writeTOC(timer)

      CALL SYSTEM("echo '\n'END OF THE RUN - $(date)'\n'")

      END PROGRAM

max_stars_repo_name: rtagirov/nessy

max_issues_repo_name: rtagirov/nessy

max_forks_repo_name: rtagirov/nessy-src


text:
PROGRAM LUCAS_LEHMER
  IMPLICIT NONE

  INTEGER, PARAMETER :: i64 = SELECTED_INT_KIND(18)
  INTEGER(i64) :: s, n
  INTEGER :: i, exponent

  DO exponent = 2, 31
     IF (exponent == 2) THEN
        s = 0
     ELSE
        s = 4
     END IF
     n = 2_i64**exponent - 1
     DO i = 1, exponent-2
        s = MOD(s*s - 2, n)
     END DO
     IF (s==0) WRITE(*,"(A,I0,A)") "M", exponent, " is PRIME"
  END DO

END PROGRAM LUCAS_LEHMER

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
      program wtype2
      call foo(x)
      end
      subroutine foo(y)
      real y(10)
      y(3)=0
      end