text:
!
! NAME:
!       Interpolate_AIRS_SRFs
!
! PURPOSE:
!       Program to read the requested AIRS SRF data from a netCDF format
!       file and interpolate the SRFs to the same frequency grid  used in
!       the line-by-line transmittance data files. The interpolated files
!       are output in netCDF format by module based upon the SensorInfo
!       file.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 03-May-2002
!                       paul.vandelst@ssec.wisc.edu
!

PROGRAM Interpolate_AIRS_SRFs

  ! ------------
  ! Module usage
  ! ------------

  USE Type_Kinds
  USE File_Utility
  USE Message_Handler
  USE Interpolate_Utility
  USE SensorInfo_Define
  USE SensorInfo_LinkedList
  USE SensorInfo_IO
  USE AIRS_SRF_Define
  USE AIRS_SRF_netCDF_Reader
  USE SRF_Define
  USE SRF_netCDF_IO
  USE Tau_Production_Parameters

  ! ---------------------------
  ! Disable all implicit typing
  ! ---------------------------

  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------

  CHARACTER( * ),  PARAMETER :: PROGRAM_NAME = 'Interpolate_AIRS_SRFs'
  CHARACTER( * ),  PARAMETER :: PROGRAM_RCS_ID = &

  ! -- Input AIRS SRF filename
  CHARACTER( * ),  PARAMETER ::  AIRS_SRF_FILENAME = 'airs_srf.nc'

  ! -- Numeric literal
  REAL( fp_kind ), PARAMETER :: ONEpointFIVE = 1.5_fp_kind

  ! -- The index for the required frequency interval = 2
  ! -- This corresponds to the 0.0025cm^-1 frequency interval
  ! -- from the Tau_Production_Parameters module.
  INTEGER, PARAMETER :: INTERPOLATION_INDEX = 2

  ! -- Interpolation order
  ! -- If 1 == linear
  ! --    3 == cubic
  INTEGER, PARAMETER :: ORDER = 1

  ! -- Keyword set (TRUE/ON) value
  INTEGER, PARAMETER :: SET = 1

  ! ---------
  ! Variables
  ! ---------

  CHARACTER( 256 ) :: Message

  INTEGER         :: pn_pos
  CHARACTER( 80 ) :: pn_fmt

  CHARACTER( 256 ) :: SensorInfo_FileNAME
  CHARACTER( 256 ) :: iSRF_FileNAME

  INTEGER :: Error_Status

  CHARACTER( 256 ) :: Comment

  REAL( fp_kind ) :: dF
  INTEGER :: l, n_iPoints, i1, i2

  TYPE( AIRS_SRF_type ) :: AIRS_SRF
  TYPE( SRF_type )      :: iSRF

  INTEGER :: n_Sensors, n
  TYPE( SensorInfo_type )      :: SensorInfo
  TYPE( SensorInfo_List_type ) :: SensorInfo_List

  !#----------------------------------------------------------------------------#
  !#                   -- INITIALIZE LINKED LIST STRUCTURE --                   #
  !#----------------------------------------------------------------------------#

  SensorInfo_List = New_SensorInfo_List()

  !#----------------------------------------------------------------------------#
  !#                       -- OUTPUT DESCRIPTIVE HEADER --                      #
  !#----------------------------------------------------------------------------#

  CALL Program_Message(PROGRAM_NAME, &
                       'Program to read the netCDF format AIRS SRF data files and '//&
                       'interpolate the requested SRFs to the same frequency '//&
                       'grid used in the line-by-line transmittance data files.', &
                       '$Revision: 2.3 $' )

  !#----------------------------------------------------------------------------#
  !#                       -- READ THE SensorInfo FILE --                       #
  !#----------------------------------------------------------------------------#

  ! ---------------------------
  ! Get the SensorInfo filename
  ! ---------------------------

  WRITE( *, FMT     = '( /5x, "Enter a SensorInfo filename: " )', &
            ADVANCE = 'NO' )
  READ( *, FMT = '( a )' ) SensorInfo_Filename
  SensorInfo_Filename = ADJUSTL( SensorInfo_Filename )

  ! -----------------------------------
  ! Populate the SensorInfo linked list
  ! -----------------------------------

  Error_Status = Read_SensorInfo( SensorInfo_Filename, &
                                  SensorInfo_List, &
                                  Quiet = SET )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error reading SensorInfo file '//&
                          TRIM( SensorInfo_Filename ), &
                          FAILURE )
    STOP
  END IF

  ! ---------------------------
  ! Count the number of sensors
  ! ---------------------------

  n_Sensors = Count_SensorInfo_Nodes( SensorInfo_List )

  IF ( n_Sensors < 1 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'SensorInfo_List is empty.', &
                          FAILURE )
    STOP
  END IF

  !#----------------------------------------------------------------------------#
  !#           -- DEFINE THE FREQUENCY INTERPOLATION INFORMATION --             #
  !#----------------------------------------------------------------------------#

  dF = FREQUENCY_INTERVAL( INTERPOLATION_INDEX )

  !#----------------------------------------------------------------------------#
  !#            --INQUIRE THE INPUT AIRS SRF FILE FOR VERSION INFO --           #
  !#----------------------------------------------------------------------------#

  Error_Status = Inquire_AIRS_SRF_netCDF( AIRS_SRF_FILENAME, &
                                          Version = Comment )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL display_message( PROGRAM_NAME, &
                          'Error inquiring input AIRS SRF file '//AIRS_SRF_FILENAME, &
                          FAILURE )
    STOP
  END IF

  ! -- Modify COMMENT attribute
  Comment = 'Interpolated SRFs for transmittance production;'//TRIM( Comment )

  !#----------------------------------------------------------------------------#
  !#                      -- BEGIN LOOP OVER SENSORS --                         #
  !#----------------------------------------------------------------------------#

  Sensor_Loop: DO n = 1, n_Sensors

    ! ---------------------------------------------
    ! Get the current SensorInfo data from the list
    ! ---------------------------------------------

    Error_Status = GetFrom_SensorInfo_List( SensorInfo_List, &
                                            n, &
                                            SensorInfo )

    IF ( Error_Status /= SUCCESS ) THEN
      Error_Status = FAILURE
      WRITE( Message, '( "Error retrieving SensorInfo data for sensor # ", i5 )' ) n
      CALL display_message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

    !#--------------------------------------------------------------------------#
    !#                       -- OPERATE ONLY ON AIRS --                         #
    !#--------------------------------------------------------------------------#

    AIRS_Only: IF ( TRIM( SensorInfo%Sensor_Name ) == 'AIRS' ) THEN

      ! ---------------------------------
      ! Construct the output SRF filename
      ! ---------------------------------

      iSRF_Filename = TRIM( SensorInfo%File_Prefix )//'.srf.nc'

      WRITE( *, '(/5x, "Processing SRF file ", a, "..." )' ) TRIM( iSRF_FileNAME )

      ! --------------------------------------------
      ! Create the output interpolated srf data file
      ! --------------------------------------------

      Error_Status = Create_SRF_netCDF( TRIM( iSRF_FileNAME ), &
                                        SensorInfo%Sensor_Channel, &
                                        NCEP_Sensor_ID   = SensorInfo%NCEP_Sensor_ID, &
                                        WMO_Satellite_ID = SensorInfo%WMO_Satellite_ID, &
                                        WMO_Sensor_ID    = SensorInfo%WMO_Sensor_ID, &
                                        Title         = 'Normalized sounder spectral response functions for '//&
                                                        TRIM( SensorInfo%File_Prefix ), &
                                        History       = PROGRAM_RCS_ID, &
                                        Sensor_Name   = TRIM( SensorInfo%Sensor_Name ), &
                                        Platform_Name = TRIM( SensorInfo%Satellite_Name ), &
                                        Comment       = TRIM( Comment ) )

      IF ( Error_Status /= SUCCESS ) THEN
        CALL display_message( PROGRAM_NAME, &
                              'Error creating '//TRIM( iSRF_FileNAME ), &
                              Error_Status )
        STOP
      END IF

      !#------------------------------------------------------------------------#
      !#                     -- LOOP OVER THE CHANNELS --                       #
      !#------------------------------------------------------------------------#

      Channel_Loop: DO l = 1, SensorInfo%n_Channels

        ! ---------------------------------------
        ! Read the current channel input SRF data
        ! ---------------------------------------

        Error_Status = Read_AIRS_SRF_netCDF( AIRS_SRF_FILENAME, &
                                             SensorInfo%Sensor_Channel(l), &
                                             AIRS_SRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error reading AIRS channel #", i4, " SRF from ", a )' ) &
                          SensorInfo%Sensor_Channel(l), AIRS_SRF_FILENAME
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! ------------------------------------
        ! Assign the channel number and sensor
        ! IDs to the interpolation structure
        ! ------------------------------------

        iSRF%Channel = SensorInfo%Sensor_Channel(l)
        iSRF%NCEP_Sensor_ID   = SensorInfo%NCEP_Sensor_ID
        iSRF%WMO_Satellite_ID = SensorInfo%WMO_Satellite_ID
        iSRF%WMO_Sensor_ID    = SensorInfo%WMO_Sensor_ID

        ! ----------------------------------------------------
        ! Calculate the begin and end interpolated frequencies
        ! and the number of interpolated points
        ! ----------------------------------------------------

        ! -- The begin point and frequency
        i1 = INT( ONEpointFIVE + ( ( AIRS_SRF%Begin_Frequency - FREQUENCY_BEGIN ) / &
             !                     ----------------------------------------------
                                                         dF                       ) )

        iSRF%Begin_Frequency = FREQUENCY_BEGIN + ( REAL( i1 - 1, fp_kind ) * dF )

        ! -- The end point and frequency
        i2 = INT( ONEpointFIVE + ( ( AIRS_SRF%End_Frequency - FREQUENCY_BEGIN ) / &
             !                     --------------------------------------------
                                                        dF                      ) )

        iSRF%End_Frequency = FREQUENCY_BEGIN + ( REAL( i2 - 1, fp_kind ) * dF )

        ! -- Total number of points
        n_iPoints = i2 - i1 + 1

        ! ----------------------------------------------
        ! Allocate the interpolated SRF structure arrays
        ! ----------------------------------------------

        Error_Status = Allocate_SRF( n_iPoints, iSRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error allocating iSRF arrays for channel #", i4, "." )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! ----------------------------------------
        ! Compute the interpolation frequency grid
        ! ----------------------------------------

        Error_Status = Frequency_SRF( iSRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error computing the interpolation frequency grid ", &
                            &"for channel #", i5 )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! -------------------------
        ! Interpolate the input SRF
        ! -------------------------

        Error_Status = Polynomial_Interpolate( AIRS_SRF%Frequency, &
                                               AIRS_SRF%Response, &
                                               iSRF%Frequency, &
                                               iSRF%Response, &
                                               Order = ORDER )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error interpolating SRF for channel #", i4 )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! -- Normalise it
        iSRF%Response = iSRF%Response / MAXVAL( iSRF%Response )

        ! ------------------------------
        ! Integrate the interpolated SRF
        ! ------------------------------

        Error_Status = Integrate_SRF( iSRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error integrating channel #", i4, " interpolated SRF." )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! -- Output the integration comparisons
        WRITE( *, '( 10x, "Interpolated AIRS channel ", i5, " SRF. ", &
                         &"Integrated SRF: ", es13.6, 5x, &
                         &"Summed SRF: ", es13.6, 5x, &
                         &"% difference: ", es13.6 )' ) &
                  SensorInfo%Sensor_Channel(l), &
                  iSRF%Integrated_SRF, &
                  iSRF%Summation_SRF, &
                  100.0_fp_kind * ( iSRF%Integrated_SRF - iSRF%Summation_SRF ) / iSRF%Integrated_SRF

        ! ----------------------------------------
        ! Write the channel SRF to the netCDF file
        ! ----------------------------------------

        Error_Status = Write_SRF_netCDF( TRIM( iSRF_FileNAME ), &
                                         iSRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error occurred writing channel #", i5, &
                            &" interpolated SRF to ", a, "." )' ) &
                          iSRF%Channel, TRIM( iSRF_FileNAME )
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! ---------------------------------------
        ! Destroy SRF structures for next channel
        ! ---------------------------------------

        ! -- The interpolated SRF
        Error_Status = Destroy_SRF( iSRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error occurred destroying channel #", i4, &
                            &" iSRF structure." )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME, &
                                TRIM( Message ), &
                                Error_Status )
          STOP
        END IF

        ! -- The input SRF
        Error_Status = Destroy_AIRS_SRF( AIRS_SRF )

        IF ( Error_Status /= SUCCESS ) THEN
          WRITE( Message, '( "Error occurred destroying channel #", i4, &
                           & " AIRS_SRF structure." )' ) &
                          SensorInfo%Sensor_Channel(l)
          CALL display_message( PROGRAM_NAME,    &
                                TRIM( Message ), &
                                Error_Status     )
          STOP
        END IF

      END DO Channel_Loop

    END IF AIRS_Only

    !#--------------------------------------------------------------------------#
    !#              -- DESTROY THE CURRENT SensorInfo STRUCTURE --              #
    !#--------------------------------------------------------------------------#

    Error_Status = Destroy_SensorInfo( SensorInfo )

    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message, '( "Error destroying SensorInfo data for sensor # ", i5 )' ) n
      CALL display_message( PROGRAM_NAME, &
                            TRIM( Message ), &
                            Error_Status )
      STOP
    END IF

  END DO Sensor_Loop

  !#----------------------------------------------------------------------------#
  !#                  -- DESTROY THE SensorInfo LINKED LIST --                  #
  !#----------------------------------------------------------------------------#

  Error_Status = Destroy_SensorInfo_List( SensorInfo_List )

  IF ( Error_Status /= SUCCESS ) THEN
    CALL display_message( PROGRAM_NAME, &
                          'Error destroying SensorInfo linked list.', &
                          WARNING )
  END IF

END PROGRAM Interpolate_AIRS_SRFs

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm


text:
C This file are aux functions for stand-alone use
C of CORSIKA interaction models

      SUBROUTINE CQGSINI( SEEDIN, DATDIR, LUN, DEBUGNUM )
C-----------------------------------------------------------------------
C  C(ompact) Q(UARK) G(LUON) S(TRING JET MODEL) INI(TIALZATION)
C
C  INITIALIZES QGSJET-II MODEL quitely and fully.
C  THIS SUBROUTINE IS CALLED FROM START.
C-----------------------------------------------------------------------
      IMPLICIT NONE
      CHARACTER DATDIR*(256)
      COMMON /AREA40/  JDIFR
      INTEGER          JDIFR
      INTEGER        VERSION
      INTEGER    LUN, moniou
      INTEGER    DEBUGNUM, debug
      common /qgarr43/ moniou
      common /qgdebug/ debug

      INTEGER          ASEED(3)
      INTEGER          SEEDIN
      SAVE
C-----------------------------------------------------------------------

C  init the random number generator
      ASEED(1) = SEEDIN
      ASEED(2) = 0
      ASEED(3) = 0
      CALL RMMAQD( ASEED,1,'S' )
      ASEED(1) = SEEDIN
      CALL RMMAQD( ASEED,2,'S' )

C  COMMON MODEL PARAMETERS SETTING
      CALL QGSET
      moniou = LUN
      debug = DEBUGNUM
C  Call global initialization subroutine
      CALL QGAINI( DATDIR )
C  Call cross-section initialization subroutine
C      CALL QGSSIGINI

      END

      SUBROUTINE CHEPEVT
C-----------------------------------------------------------------------
C  Convert to HEPEVT common block
C
C-----------------------------------------------------------------------
      IMPLICIT NONE

      INTEGER NPTMAX, ICH, NSP
      DOUBLE PRECISION ESP
      PARAMETER(NPTMAX=95000)
      COMMON /QGARR12/ NSP
      COMMON /QGARR14/ ESP(4,NPTMAX),ICH(NPTMAX)

      INTEGER NEVHEP,NMXHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
      DOUBLE PRECISION PHEP,VHEP
      PARAMETER (NMXHEP=NPTMAX)
      COMMON /HEPEVT/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
     &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
     &                VHEP(4,NMXHEP)
      INTEGER ICHG
      COMMON /QGCHG/  ICHG(NMXHEP)
C     Particle tables start with the ID -10(rho0) going through 0 (pi0).
      character*12 NAME(-10:10)
      DATA NAME /
     &'rho0        ','Lambda_cbar-','Dbar0       ','D-          ',
     &'Lambdabar0  ','K_L0        ','K-          ','nbar0       ',
     &'pbar-       ','pi-         ','pi0         ','pi+         ',
     &'p+          ','n0          ','K+          ','K_S0        ',
     &'Lambda0     ','D+          ','D0          ','Lambda_c+   ',
     &'eta         '/

      INTEGER IPDGID(-10:10)
      DATA IPDGID /
     &   113, -4122,  -421,  -411, -3122,   130,  -321, -2112, -2212,
     &  -211,   111,   211,  2212,  2112,   321,   310,  3122,   411,
     &   421,  4122,   221/

      DOUBLE PRECISION QMASS(-10:10)
      DATA QMASS /
     &.548d0,2.27d0,1.868d0,1.868d0,1.116d0,.496d0,.496d0,0.93827999,
     &0.93827999,.14d0,.14d0,.14d0,0.93827999,0.93827999,.496d0,.496d0,
     &1.116d0,1.868d0,1.868d0,2.27d0,.548d0/

      INTEGER ICHRG(-10:10)
      DATA ICHRG /
     &     0,    -1,     0,    -1,     0,     0,    -1,     0,
     &    -1,    -1,     0,     1,     1,     0,     1,     0,
     &     0,     1,     0,     1,     0/

      INTEGER I

      NHEP = nsp

      DO I=1,nsp
C         WRITE(6,*) I, ich(I), esp(:,I)
         NHEP = NSP
         ISTHEP(I) = 1
         IDHEP(I) = IPDGID(ich(I))
         PHEP(1,I) = esp(3,I)
         PHEP(2,I) = esp(4,I)
         PHEP(3,I) = esp(2,I)
         PHEP(4,I) = esp(1,I)
         PHEP(5,I) = QMASS(ich(I))
         ICHG(I) = ICHRG(ich(I))
      END DO

      END

*-- Author :    D. HECK IK FZK KARLSRUHE       12/01/1996
C=======================================================================

      BLOCK DATA QGSDAT

C-----------------------------------------------------------------------
C  Q(UARK) G(LUON) S(TRING JET MODEL) DAT(A INITIALIZATION)
C
C  INITIALIZES DATA FOR QGSJET LINK.
C-----------------------------------------------------------------------

      IMPLICIT NONE
      COMMON /CRQGSLIN/ICTABL,IQTABL
      INTEGER          ICTABL(200),IQTABL(-10:10)
      SAVE
C  FOLLOWING NOTATIONS FOR PARTICLES TYPES ARE USED WITHIN QGSJET:
C             0 - PI0,
C             1 - PI+,
C            -1 - PI-,
C             2 - P,
C            -2 - P-BAR,
C             3 - N,
C            -3 - N-BAR,
C             4 - K+,
C            -4 - K-,
C             5 - K0S,
C            -5 - K0L
C             6 - LAMBDA
C            -6 - LAMBDA-BAR
C             7 - D+
C            -7 - D-
C             8 - D0
C            -8 - D0-BAR
C             9 - LAMBDA_C
C            -9 - LAMBDA_C-BAR
C            10 - ETA
C           -10 - RHO0

C  ICTABL CONVERTS CORSIKA PARTICLES INTO QGSJET PARTICLES
C  NO CHARMED PARTICLES POSSIBLE AS PROJECTILES
      DATA ICTABL/
     *   0,   0,   0,   0,   0,   0,   1,   1,  -1,  -5,   ! 10
     *   4,  -4,   3,   2,  -2,   5,  10,   6,   0,   0,   ! 20
     *   0,   0,   0,   0,  -3,  -6,   0,   0,   0,   0,   ! 30
     *   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   ! 40
     *   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   ! 50
     *   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   ! 60
     *   0,   0,   0,   0,   0,   0,   0,   0,   0,   0,   ! 70
     *  10,  10,  10,  10,   26*0,
C  CHARMED MESONS
C  CONVERT UNKNOWN CHARMED MESONS TO KNOWN D-MESONS
     *  10*0,                                              !110
     *   0,   0,   0,   0,   0,   8,   7,  -7,  -8,   7,   !120
     *  -7,   0,   8,   7,  -7,  -8,   7,  -7,   0,   0,   !130
C  CHARMED BARYONS
     *   0,   0,   0,   0,   0,   0,   9,   0,   0,   0 ,  !140
     *   0,   0,   0,   0,   0,   0,   0,   0,  -9,   0 ,  !150
     *   50*0 /

C  IQTABL CONVERTS QGSJET PARTICLES INTO CORSIKA PARTICLES
C  INCLUDES CHARMED PARTICLES
C  IQTABL RUNS FROM -10:10
      DATA IQTABL/
     *   51, 149, 119, 118,  26,  10,  12,  25,  15,   9,  ! -10 .... -1
     *   7,                                               !   0
     *   8,  14,  13,  11,  16,  18, 117, 116, 137,  17/  !   1 .... 10

      END

*-- Author :    T. Pierog IKP KIT KARLSRUHE       25/10/2012
C=======================================================================

      subroutine  LzmaOpenFile(name)

C-----------------------------------------------------------------------
C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC
C-----------------------------------------------------------------------

      IMPLICIT NONE
      character*256 name,name2
      name2=name
      end

*-- Author :    T. Pierog IKP KIT KARLSRUHE       25/10/2012
C=======================================================================

      subroutine  LzmaCloseFile()

C-----------------------------------------------------------------------
C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC
C-----------------------------------------------------------------------

      IMPLICIT NONE
      end

*-- Author :    T. Pierog IKP KIT KARLSRUHE       25/10/2012
C=======================================================================

      subroutine LzmaFillArray(dum,idum)

C-----------------------------------------------------------------------
C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC
C-----------------------------------------------------------------------

      IMPLICIT NONE
      double precision dum,dum2
      integer idum,idum2
      dum2=dum
      idum2=idum
      end

*-- Author :    T. Pierog IKP KIT KARLSRUHE       25/10/2012
C=======================================================================

      integer function size(array)

C-----------------------------------------------------------------------
C DUMMY FUNCTION TO BE COMPATIBLE WITH CRMC
C-----------------------------------------------------------------------

      IMPLICIT NONE
      double precision array(*)
      size=int(array(1))
      end

ext: f

max_stars_repo_name: kotania/impy

max_issues_repo_name: kotania/impy

max_forks_repo_name: kotania/impy


! PR libfortran/47757
! { dg-do run }

  integer(1) :: a1(2,2)
  integer(2) :: a2(2,2)
  integer(4) :: a4(2,2)
  integer(8) :: a8(2,2)
  logical :: mask(2,2)
  logical :: mask2
  a1 = 0
  a2 = 0
  a3 = 0
  a4 = 0
  mask2 = .true.
  mask = reshape([.true.,.true.,.false.,.true.],[2,2])
  print *, iany(a1, dim=1, mask=mask)
  print *, iany(a2, dim=1, mask=mask)
  print *, iany(a4, dim=1, mask=mask)
  print *, iany(a8, dim=1, mask=mask)
  print *, iall(a1, dim=1, mask=mask)
  print *, iall(a2, dim=1, mask=mask)
  print *, iall(a4, dim=1, mask=mask)
  print *, iall(a8, dim=1, mask=mask)
  print *, iparity(a1, dim=1, mask=mask)
  print *, iparity(a2, dim=1, mask=mask)
  print *, iparity(a4, dim=1, mask=mask)
  print *, iparity(a8, dim=1, mask=mask)
  print *, iany(a1, dim=1, mask=mask2)
  print *, iany(a2, dim=1, mask=mask2)
  print *, iany(a4, dim=1, mask=mask2)
  print *, iany(a8, dim=1, mask=mask2)
  print *, iall(a1, dim=1, mask=mask2)
  print *, iall(a2, dim=1, mask=mask2)
  print *, iall(a4, dim=1, mask=mask2)
  print *, iall(a8, dim=1, mask=mask2)
  print *, iparity(a1, dim=1, mask=mask2)
  print *, iparity(a2, dim=1, mask=mask2)
  print *, iparity(a4, dim=1, mask=mask2)
  print *, iparity(a8, dim=1, mask=mask2)
end


text:
!##############################################################################
!# ****************************************************************************
!# <name> preproctest </name>
!# ****************************************************************************
!#
!# <purpose>
!#
!# This simple program contains several typical tests for the
!# preprocessor. Preprocessing is supported natively by some Fortran
!# compilers (using fpp) but others do not provide a dedicated Fortran
!# preprocessor so that the C preprocessor cpp has to be used.  Since
!# cpp does not know about special Fortran syntax, e.g., the maximum
!# length of 132 characters per line and the line continuation symbol
!# '&', cpp is embedded into the f90cpp script which pre-preprocesses
!# the source code passed to cpp and post-preprocesses the outcome in
!# order to handle Fortran specific constructions. Since this is not a
!# trivial task, this test suite contains most of the typical
!# constructions that have to be handled correctly by f90cpp.
!#
!# Moreover, the Featflow2 source code should compile natively under
!# Windows which means that no configure-based build system is
!# available, and thus, the source code must comply with the standard
!# Fortran preprocessor fpp.
!#
!# </purpose>
!##############################################################################

program preproctest

#include "kernel/feat2constants.h"
#include "kernel/feat2macros.h"
#include "kernel/System/idxmanager.h"
#include "preproctest.h"

  use fsystem
  implicit none

  real(DP), dimension(8) :: AVeryLongVariableName = 1
  real(DP), dimension(8) :: YetAnotherVeryLongVariableName = 1

  ! Test #1: Call to macro with very long variable names so that the maximum
  !          length of 132 characters per line is exceeded. There exist the
  !          following remedies to this violation of the Fortran standard:
  !
  !          (a) lines are truncated manually and continued in the next
  !              line using the keyword 'mynewline' (written in upper case).
  !              This keyword is recognized by f90cpp and converted into '&\n'
  !              after the file has been preprocessed by the preprocessor.
  !              This is the default way if the script f90cpp is used.
  !
  !          (b) the Fortran preprocessor truncates long lines and inserts
  !              line continuation symbols '&' automatically.
  !              This is the case if the SUN Fortran preprocessor is used.
  !
  !          (c) the Fortran compiler does support lines with mode then 132
  !              characters, and therefore, the Fortran preprocessor does
  !              not take special care about extra long lines.
  !              This is the case if the Intel Fortran preprocessor is used.

  write(*,*) "Test #1: Call to macro with very long variable names"
  write(*,*) euclidnorm8(AVeryLongVariableName), sqrt(sum(AVeryLongVariableName**2))
  write(*,*)

  ! Test #2: Call to a macro with arguments over multiple lines.
  !          The maximum length of the macro call would be long and therefore
  !          difficult to read in the source code so that it is truncated and
  !          continued in the next line. Note that no 'mynewline' is required
  !          since we do not want to enforce a linebreak in the preprocessed
  !          code but just extend a macro call over multiple lines.
  !          Depending on the preprocessor the line is either merged into a
  !          singe line before macro expansion or kept as is.

  write(*,*) "Test #2: Call to a macro over multiple lines"
  write(*,*) combine(\
    euclidnorm8(AVeryLongVariableName),\
    euclidnorm8(YetAnotherVeryLongVariableName))
  write(*,*)

  ! Test #3: Call to a macro inside a list of other arguments.
  !          This test extends Test #2 in the following sense. The preprocessor
  !          must not add extra lines after the expanded macro call because then
  !          the Fortran compiler may complain about unbalance parantheses.
  !          For this reasons, newer versions of the GNU cpp must be invoked with
  !          the '--traditional' flag. Otherwise, the following test fails.

  write(*,*) "Test #3: Call to a macro inside other arguments"
  call writeTwoArguments(combine(\
  euclidnorm8(AVeryLongVariableName),\
  euclidnorm8(YetAnotherVeryLongVariableName)),&
      sqrt(sum(AVeryLongVariableName**2))+&
      sqrt(sum(YetAnotherVeryLongVariableName**2)))
  write(*,*)

  ! Test #4: The preprocessor should not manipulate comments which include
  !          characters such as backslashes which would normally be interpreted
  !          as line continuation symbols by the C preprocessor. This special
  !          case is handled by perl command (4) in script f90cpp.
  !
  !          It applies to ASCII arts of the form
  !
  !          / a_11  a_12  a_13  a_14 \
  !          | a_21  a_22  a_23  a_24 |
  !          | a_31  a_32  a_33  a_34 |
  !          \ a_41  a_42  a_43  a_44 /
  !
  !          as well as to LaTeX forced line breaks in comments, e.g.
  !
  !          $$ M = left(\begin{array}{cccc}
  !                      a_{11} & a_{12} & a_{13} & a_{14}\\
  !                      a_{21} & a_{22} & a_{23} & a_{24}\\
  !                      a_{31} & a_{32} & a_{33} & a_{34}\\
  !                      a_{41} & a_{42} & a_{43} & a_{44}
  !                 \end{array}\right) $$

  ! Remark: In the write statements below it is necessary to have a white space
  !         between the backslash and the quotation mark. This has nothing to
  !         to with the preprocessor but could be misinterpreted by some Fortran
  !         compilers (e.g., PGI Fortran 90 Compiler version 9.0-4). Not yet sure
  !         if this is a bug in the PGI compiler or not valid according to the
  !         Fortran 90 standard.

  write(*,*) "Test #4: Correct treatment of special characters in comments"
  write(*,*) "/ a_11  a_12  a_13  a_14 \ "
  write(*,*) "| a_21  a_22  a_23  a_24 |"
  write(*,*) "| a_31  a_32  a_33  a_34 |"
  write(*,*) "\ a_41  a_42  a_43  a_44 /"
  write(*,*)

  ! Test #5: The preprocessor must not interpred Fortran 90 string
  !          concatination operators ('//'). This special case is
  !          handled by perl command (2) in script f90cpp.

  write(*,*) "Test #5: Correct treatment of Fortran 90 string concatenation"
  write(*,*) "Foo"//"bar"
  write(*,*)

  ! Test #6: Stringification of a macro argument. This feature is
  !          supported by all preprocessors which support ANSI C. The
  !          internal preprocessor of GNU gfortran and g95 invokes cpp
  !          with the '-traditional' flag turned on. In this case
  !          stringification works if the argument to the
  !          stringification macro is fixed.

  write(*,*) "Test #6: Stringification of macro arguments"
  write(*,*) FEAT2_PP_STRING(print)
  write(*,*)

  ! Test #7: Concatenation of two arguments.

  write(*,*) "Test #7: Concatenation of two macro arguments"
  write(*,*) FEAT2_PP_CONCAT(1,0)
  write(*,*)

  ! Test #8: Stringification of a macro argument which is the result
  !          of further macros. This feature is supported by all
  !          preprocessors which support ANSI C. However, the
  !          traditional cpp used internally by GNU gfortran and g95
  !          is not able to evaluating the arguments prior to
  !          converting them into string.

  write(*,*) "Test #8: Concatenation of two macro arguments"
  write(*,*) FEAT2_PP_STRING(FEAT2_PP_CONCAT(foo,bar))
  write(*,*)

  ! Test #9: Conversion of floating point number to constant
  write(*,*) "Test #9: Conversion of FP-number to single precision constant"
  write(*,*) FEAT2_PP_CONST(1.0/3.0,SINGLE_PREC)
  write(*,*) "         Conversion of FP-number to double precision constant"
  write(*,*) FEAT2_PP_CONST(1.0/3.0,DOUBLE_PREC)
  write(*,*) "         Conversion of FP-number to quad precision constant"
  write(*,*) FEAT2_PP_CONST(1.0/3.0,QUAD_PREC)
  write(*,*)

  ! Test #10: Automatic language detection (including manual overriding)
  write(*,*) "Test #10: Automatic language detection feature"
  write(*,*) "Global variable LANGUAGE unset:"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)

#define LANGUAGE LANGUAGE_C
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C:"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE

#define LANGUAGE LANGUAGE_F
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F:"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_LANGUAGE(LANGUAGE_F), "with parameter LANGUAGE_C"
  write(*,*)
#undef LANGUAGE

  ! Test #11: Automatic detection of index manager addressing
  write(*,*) "Test #11: Automatic detection of index manager addressing"
  write(*,*) "Global variables LANGUAGE and IDXADDR unset:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)

#define LANGUAGE LANGUAGE_C
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and IDXADDR unset:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE

#define LANGUAGE LANGUAGE_F
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and IDXADDR unset:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE

#define IDXADDR IDXADDR_C
  write(*,*) "Global variable LANGUAGE unset and and IDXADDR set to IDXADDR_C:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR

#define IDXADDR IDXADDR_F
  write(*,*) "Global variable LANGUAGE unset and and IDXADDR set to IDXADDR_F:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR

#define LANGUAGE LANGUAGE_C
#define IDXADDR IDXADDR_C
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and IDXADDR set to IDXADDR_C:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR
#define IDXADDR IDXADDR_F
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and IDXADDR set to IDXADDR_F:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR
#undef LANGUAGE

#define LANGUAGE LANGUAGE_F
#define IDXADDR IDXADDR_C
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and IDXADDR set to IDXADDR_C:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR
#define IDXADDR IDXADDR_F
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and IDXADDR set to IDXADDR_F:"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXADDR(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef IDXADDR
#undef LANGUAGE

  ! Test #12: Automatic detection of index manager memory layout
  write(*,*) "Test #11: Automatic detection of index manager memory layout"
  write(*,*) "Global variables LANGUAGE and MEMORY_LAYOUT unset:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)

#define LANGUAGE LANGUAGE_C
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and MEMORY_LAYOUT unset:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE

#define LANGUAGE LANGUAGE_F
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and MEMORY_LAYOUT unset:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE

#define MEMORY_LAYOUT ROW_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE unset and and MEMORY_LAYOUT set to ROW_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT

#define MEMORY_LAYOUT COLUMN_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE unset and and MEMORY_LAYOUT set to COLUMN_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT

#define LANGUAGE LANGUAGE_C
#define MEMORY_LAYOUT ROW_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and MEMORY_LAYOUT set to ROW_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT
#define MEMORY_LAYOUT COLUMN_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_C and MEMORY_LAYOUT set to COLUMN_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT
#undef LANGUAGE

#define LANGUAGE LANGUAGE_F
#define MEMORY_LAYOUT ROW_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and MEMORY_LAYOUT set to ROW_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT
#define MEMORY_LAYOUT COLUMN_MAJOR_ORDER
  write(*,*) "Global variable LANGUAGE set to LANGUAGE_F and MEMORY_LAYOUT set to COLUMN_MAJOR_ORDER:"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_MEMORY_LAYOUT(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef MEMORY_LAYOUT
#undef LANGUAGE

  ! Test #13: Automatic detection of offset for index addressing
  !           For this test to work properly we need to define the following macros
#define ZERO      " 0 "
#define PLUS_ONE  "+1 "
#define MINUS_ONE "-1 "

  write(*,*) "Test #11: Automatic detection of offset for index addressing"
  write(*,*) "Global variables LANGUAGE and IDXADDR unset:"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)

#define LANGUAGE LANGUAGE_C
#define IDXADDR IDXADDR_C
  write(*,*) "Global variables LANGUAGE set to LANGUAGE_C and IDXADDR set to IDXADDR_C:"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE
#undef IDXADDR

#define LANGUAGE LANGUAGE_F
#define IDXADDR IDXADDR_C
  write(*,*) "Global variables LANGUAGE set to LANGUAGE_F and IDXADDR set to IDXADDR_C:"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE
#undef IDXADDR

#define LANGUAGE LANGUAGE_C
#define IDXADDR IDXADDR_F
  write(*,*) "Global variables LANGUAGE set to LANGUAGE_C and IDXADDR set to IDXADDR_F:"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE
#undef IDXADDR

#define LANGUAGE LANGUAGE_F
#define IDXADDR IDXADDR_F
  write(*,*) "Global variables LANGUAGE set to LANGUAGE_F and IDXADDR set to IDXADDR_F:"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(), "without parameter"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_C), "with parameter LANGUAGE_C"
  write(*,*) FEAT2_PP_AUTO_IDXOFFSET(LANGUAGE_F), "with parameter LANGUAGE_F"
  write(*,*)
#undef LANGUAGE
#undef IDXADDR

contains

  subroutine writeTwoArguments(a,b)
    real(DP), intent(in) :: a,b

    write(*,*) a,b

  end subroutine writeTwoArguments

end program preproctest

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
subroutine dp999(dp        ,nmax      ,mmax      ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: dp999.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/io/src/output/dp999.f90 $
!!--description-----------------------------------------------------------------
!
! Replace the -999.0 from QUICKIN default value  by 0.0.
! This is needed because it distorts
! the scales for the cross-section plots...........................
! Paremeter iscrtk is here used as a dummy flag for real online
! visualisation
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
!
! Global variables
!
    integer :: mmax, nmax
    real(fp), dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub) :: dp
    intent (in) mmax, nmax
!
! Local variables
!
    integer :: m, n
!
!! executable statements -------------------------------------------------------
!
    do m = 1, mmax
       do n = 1, nmax
          if (abs(dp(n, m) + 999.000)<=1.0e-5) dp(n, m) = 0.0
       enddo
    enddo
end subroutine dp999

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
Once upon a time, a single empty space was created and placed on the web. It was clean, perfect and stable, albeit empty. Soon after its creation a user created an option to edit this space and became known as an editor. The following day, another editor saw what the first had done and reverted the space back to its original, perfect state. This went on and on until the two finally discussed the issue and decided there was no harm in leaving the edit button as long as the majority of the space remained blank and perfect.

A short time after this, another editor found the space and posted a small paragraph of text on it describing what the space reminded him of. It was a space of perfection that reminded him of his need to create perfection in his own life. The other editors chimed in, of course, and the second revert war was begun. Eventually, all of them finally agreed that there was nothing wrong with the page as it stood, so long as no one added anything new to it. However, as luck would have it, another editor noticed a grammatical error and fixed it, adding a humorous joke about the imperfection on the perfect page. The third revert war was begun.

Over time, the space changed again and again. New information was added, sometimes causing much heated debate, while at other times it was removed causing an equal amount of disgruntled discussion. Again and again it happened until, at last, one of the older editors began screaming at the new editors for even the tiniest of changes. A new discussion about rules and regulations had begun, and these too changed over time.

Years passed and the trend never changed new editors, more debate, more rules, more changes.

One day an editor made a remark that offended another and the cry of Ban him! Ban him! was heard throughout the multiple spaces that had been created over the years. Then another cry over another editor, and another and another... It went on and on until one editor finally took them at their word and banned them all, deleted all the information and left the space, once again, empty and perfect and without an option to edit.

The moral of the story

If you want to make a change, take a look in the mirror and begin to make honest change before trying to alter others views.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      program t
C test for a and x in format-item-list
      character*5::a='hello'
      character*5::b='world'
 1234 format(2(3X,a3))
      write (*,1234) a,b
      endprogram t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
subroutine mkbser(nbsem,nbsev,nbsec,nqpt,ncg,nkpt,npwt,igmx,igmn, &
& nsym,natom,ngkpt,ncband,nlmn,npwup,symrel,syminv,ihlf,kg, &
& igndx,lvtrans,indxkpw,indxkbnd,indxkcg,npwarr,pwupmin,pwupmax, &
& vol,pi,xred,kpt,shiftk,cg,pwmatel,tpwmatel,projwf,bser)
implicit none
integer :: nsem,nbsev,nbsec,nqpt,ncg,nkpt,npwt,igmx(3),igmn(3),nsym,natom
integer :: ngkpt(3),ncband,nlmn,npwup
integer :: symrel(3,3,nsym),syminv(3,3,nsym),ihlf(nkpt),kg(3,npwt)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: indxkpw(nkpt),indxkbnd(nkpt)
integer :: indxkcg(nkpt),npwarr(nkpt)
integer :: pwupmin(3),pwupmax(3)
double precision :: vol,pi,xred(3,natom)
double precision :: kpt(3,nkpt),shiftk(3)
double complex :: cg(ncg)
double complex :: pwmatel(nlmn,nlmn,npwup,ngkpt(1),ngkpt(2),ngkpt(3)), &
&                tpwmatel(nlmn,nlmn,npwup,ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: projwf(natom,nlmn,nkpt,ncband)
double precision :: bser(nbsem,nbsem)
integer :: iv,jv,ic,jc,iqpt,jqpt,ikk(3),jkk(3),ikpt,jkpt,igg(3),iqq(3),iqqpt
integer :: ivpw(3),ipwup,ipw,iipw,ii,jj,isym,jsym
double precision :: xkk(3),ykk(3),qq(3),qg2
double complex :: xidir,xix,cmatel,amatel,xmatel1,xmatel2,xmatel3,xmatel4

 igg0=(/0,0,0/)
 qq0=(/0.d0,0.d0,0.d0/)

 do ibsem=1,nbsem  ! ibsem=(iv-nbocc+nbsec-1)*nqpt*nbsec+(ic-nbocc-1)*nqpt+iqpt
   iv=(ibsem-1)/(nqpt*nbsec)+nbocc+1-nbsev
   ic=mod((ibsem-1)/nqpt,nbsec)+nbocc+1
   iqpt=mod(ibsem-1,nqpt)+1
   xkk=qpt(:,iqpt)
   ikk=nint(xkk*ngkpt)+ngkpt/2
   ikpt=ikndx(ikk(1),ikk(2),ikk(3))
   isym=isymndx(ikk(1),ikk(2),ikk(3))
   do jbsem=1,nbsem
     jv=(jbsem-1)/(nqpt*nbsec)+nbocc+1-nbsev
     jc=mod((jbsem-1)/nqpt,nbsec)+nbocc+1
     jqpt=mod(jbsem-1,nqpt)+1
     ykk=qpt(:,jqpt)
     jkk=nint(ykk*ngkpt)+ngkpt/2
     iqq=mod((ikk-jkk)-1,ngkpt)+1
     qq=dble(iqq)/dble(ngkpt)-0.5d0   ! xkk-ykk, shifted to 1st BZ
     igg=(ikk-jkk-iqq)/ngkpt  ! plane wave shift of qq to 1st BZ
     iqqpt=iqndx(iqq(1),iqq(2),iqq(3))
     jkpt=ikndx(jkk(1),jkk(2),jkk(3))
     jsym=isymndx(jkk(1),jkk(2),jkk(3))
     xidir=0.d0 ! direct matrix element
     xix=0.d0   ! exchange matrix element
     do ipw=1,npw
       ivpw=kg(:,indxkpw(ikpt)+ipw)  ! plane wave vector
       if (ivpw(1).ge.pwupmin(1).and.ivpw(1).le.pwupmax(1).and.    &
&          ivpw(2).ge.pwupmin(2).and.ivpw(2).le.pwupmax(2).and.    &
&          ivpw(3).ge.pwupmin(3).and.ivpw(3).le.pwupmax(3)) then
         ipwup=invpwndx(ivpw(1),ivpw(2),ivpw(3))
       else
         ipwup=0
       endif
       if (ipwup.ne.0) then
         qg2=0.d0
         do ii=1,3
         do jj=1,3
           qg2=qg2+(ivpw(ii)+qq(ii))*bmet(ii,jj)*(ivpw(jj)+qq(jj))
         enddo
         enddo
         iipw=invpw2ndx(ipwup,ipwup)
         call mkmatelX(iv,jv,ikpt,jkpt,igpw,igg, &
&          ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&          isym,jsym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&          lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&          cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&          cmatel)
!         call mkmatelP(pi,xred,natom,iv,jv,ikpt,jkpt,qq,igg,ngkpt, &
!&          pwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          tpwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel)
         xmatel1=cmatel+amatel
         call mkmatelX(ic,jc,ikpt,jkpt,igpw,igg, &
&          ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&          isym,jsym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&          lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&          cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&          cmatel)
!         call mkmatelP(pi,xred,natom,ic,jc,ikpt,jkpt,qq,igg,ngkpt, &
!&          pwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          tpwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel)
         xmatel2=cmatel+amatel
         xidir=xidir+lossfn(1,iqqpt,iipw)*xmatel1*xmatel2*4.d0*pi/qg2
       endif
       if (ipw.ne.1) then
         qg2=0.d0
         do ii=1,3
         do jj=1,3
           qg2=qg2+ivpw(ii)*bmet(ii,jj)*ivpw(jj)
         enddo
         enddo
         call mkmatelX(iv,ic,ikpt,ikpt,igpw,igg0, &
&          ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&          isym,jsym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&          lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&          cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&          cmatel)
!         call mkmatelP(pi,xred,natom,iv,ic,ikpt,ikpt,qq0,igg0,ngkpt, &
!&          pwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          tpwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel)
         xmatel3=cmatel+amatel
         call mkmatelX(jv,jc,jkpt,jkpt,igpw,igg0, &
&          ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&          isym,jsym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&          lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&          cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&          cmatel)
!         call mkmatelP(pi,xred,natom,jv,jc,jkpt,jkpt,qq0,igg0,ngkpt, &
!&          pwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          tpwmatel(:,:,ipwup,iqq(1),iqq(2),iqq(3)), &
!&          projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel)
         xmatel4=cmatel+amatel
         xix=xix+4.d0*pi*xmatel3*xmatel4/qg2
       endif
     enddo
     bser(ibsem,jbsem)=xix+xidir
   enddo
   bser(ibsem,ibsem)=bser(ibsem,ibsem)+ &
&         (enrgy(indxkbnd(ikpt)+ic)-enrgy(indxkbnd(ikpt)+iv))
 enddo

return
end subroutine mkbser

max_stars_repo_name: dinisAbranches/nwchem

max_issues_repo_name: dinisAbranches/nwchem

max_forks_repo_name: dinisAbranches/nwchem


text:
\ Structures:
\ single: eval ast. char
\ pair: eval ast. 'left 'right

\ block: apply freeze 'ast
\ s1: apply freeze 'x
\ s2: apply freeze 'x 'y
\ k1: apply freeze 'x
\ s, k, and i are premade
: eval ( ast -- func) dup @ execute ;
: ast. ( ast) dup cell+ @ execute ;

: apply ( func ast -- func) over @ execute ;
: freeze ( func -- ast) dup cell+ @ execute ;

variable sast variable kast variable iast

variable 'pair
: pair 'pair @ execute ;

: freeze-s ( func -- ast) drop sast @ ;
: freeze-k ( func -- ast) drop kast @ ;
: freeze-i ( func -- ast) drop iast @ ;

: freeze-s1 ( func -- ast) 2 cells + @ sast @ pair ;
: freeze-s2 ( func -- ast) 2 cells + dup @ sast @ pair swap cell+ @ swap pair ;
: freeze-k1 ( func -- ast) 2 cells + @ kast @ pair ;

: freeze-block ( func -- ast) 2 cells + @ ;

: apply-s2 ( func ast -- func)
   over 2 cells + @ ( func z x)
   eval over apply ( func z `xz)
   swap rot 3 cells + @ ( `xz z y)
   pair apply ; ( ``xz`yz)
: apply-s1 ( func ast -- func) here -rot ['] apply-s2 , ['] freeze-s2 ,  swap 2 cells + @ , , ;
: apply-s ( func ast -- func) nip here swap ['] apply-s1 , ['] freeze-s1 ,  , ;
create sfunc ' apply-s , ' freeze-s ,

: apply-k1 ( func ast -- func) drop 2 cells + @ eval ;
: apply-k ( func ast -- func) nip here swap ['] apply-k1 , ['] freeze-k1 ,  , ;
create kfunc ' apply-k , ' freeze-k ,

variable 'blockify
: apply-block ( func ast -- func) swap 2 cells + @ pair 'blockify @ execute ;
: blockify ( ast -- func) here swap ['] apply-block , ['] freeze-block ,  , ;
' blockify 'blockify !

: apply-i ( func ast -- func) nip eval ;
create ifunc ' apply-i , ' freeze-i ,

: eval-p ( ast -- func) 2 cells + dup @ eval swap cell+ @ apply ;
: eval-s ( ast -- func) dup 2 cells + @
   dup [char] s = if 2drop sfunc exit then
   dup [char] k = if 2drop kfunc exit then
   [char] i = if drop ifunc exit then
   blockify ;

: ast.-s ( ast) 2 cells + @ emit ;
: ast.-p ( ast) [char] ` emit 2 cells + dup @ ast. cell+ @ ast. ;

: single ( char -- ast) here swap ['] eval-s , ['] ast.-s ,  , ;
: pair ( right left -- ast) here -rot ['] eval-p , ['] ast.-p ,  , , ;
' pair 'pair !

char s single sast !
char k single kast !
char i single iast !

variable vcount
: reset ( --) 0 vcount ! ;
: ensure ( --) vcount @ 0< abort" Syntax error." ;
: up ( --) 1 vcount +! ;
: down ( --) -1 vcount +! ensure ;
: end-check ( --) vcount @ 1- abort" Syntax error." ;

: consume ( adr -- ast) c@ dup [char] ` = if down drop pair exit then up single ;
: parse ( adr count -- ast) reset over + 1- do i consume -1 +loop end-check ;

max_stars_repo_name: anschelsc/pure

max_issues_repo_name: anschelsc/pure

max_forks_repo_name: anschelsc/pure