text:
C
C	VICAR program MASTERHOT, used to calculate upwelling radiance at
C	surface from radiance at sensor for the MASTER instrument, thermal IR
C	channels (Bands 41-50).
C
C	This program is identical to MASTERTIR, except that it outputs
C	fullword pixels, rather than halfword pixels.
C
C	Ron Alley	12 August 1998
C	Revision: 1.1   Report calibration file name          rea  9/21/98
C	Revision: 1.2   get filenames from tape5              rea  5/21/99
C	Revision: 1.3   integrate over wavelengths, rather than
C			wavenumbers                           rea 10/21/99
C	Revision: 1.3.1 Update MODTRAN3 arguments             rea  7/02/01
C	Revision: 1.4   Change to fullword output             rea 10/26/04
C
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	REAL RESP(800,10),TRANX(716,10),PATHX(716,10)
	CHARACTER*80 MODINP,MODOUT,MODTAB,INPUT_NAMES(2)
	CHARACTER*80 FULLFILE,TABFILE
C						Open datasets, get size field
	CALL XVUNIT(IN,'INP',1,ISTAT,' ')
	CALL XVOPEN(IN,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +		    'U_FORMAT','REAL',' ')
	CALL XVUNIT(INCAL,'INP',2,ISTAT,' ')
	CALL XVOPEN(INCAL,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',' ')
	CALL XVUNIT(IOUT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUT,ISTAT,'IO_ACT','SA','OPEN_ACT','SA',
     +	           'OP','WRITE','U_FORMAT','FULL','O_FORMAT','FULL',
     +		   'U_ORG','BSQ','U_NB',10,'U_NL',NL,'U_NS',NS,' ')
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
	IF (NS .NE. 716) THEN
	    IF (NSIN .NE. 716) THEN
		CALL XVMESSAGE('Input image must be 716 pixels wide',' ')
		CALL ABEND
	    ENDIF
	    CALL XVMESSAGE('WARNING: NS parameter is ignored',' ')
	    CALL XVMESSAGE('The full image width will be processed',' ')
	END IF
C							      update VICAR label
	CALL XLADD(IOUT,'HISTORY','LBL1','MASTER Ground Radiance Image',
     +		   ISTAT,'FORMAT','STRING',' ')
	CALL XLADD(IOUT,'HISTORY','LBL2',
     +		       'DN = milliwatts/(m*m*sr*micrometer)',
     +		       ISTAT,'FORMAT','STRING',' ')
	CALL XLADD(IOUT,'HISTORY','LBL3',
     +		       'skyrad units = milliwatts/(m*m*micrometer)',
     +		       ISTAT,'FORMAT','STRING',' ')
	CALL XVPARM('INP',INPUT_NAMES,NUM,IDEF,2)
	CALL XLADD(IOUT,'HISTORY','CAL_FILE',INPUT_NAMES(2),ISTAT,
     +		   'FORMAT','STRING',' ')
C							Get the other parameters
	CALL XVPARM('MODINP',MODINP,NUM,IDEF,0)
C						Load spectral response functions
	DO ICHAN=1,10
	    CALL XVREAD(INCAL,RESP(1,ICHAN),ISTAT,' ')
	END DO
	CALL XVCLOSE(INCAL,ISTAT,' ')
C						Get MODTRAN parameters from
C						MODTRAN input file
	FULLFILE = 'dummy'
	TABFILE = 'dummy'
	CALL GET_MODTRAN_INPUT(MODINP,FULLFILE,TABFILE)
	CALL XVPARM('MODOUT',MODOUT,NUM,IDEF,0)
	IF (NUM .EQ. 0) MODOUT=FULLFILE
	CALL XVPARM('MODTAB',MODTAB,NUM,IDEF,0)
	IF (NUM .EQ. 0) MODTAB=TABFILE
	CALL REPORT_MODTRAN_PARMS(MODOUT,MODTAB)
C						Run MODTRAN
	CALL MODTRAN_INTERFACE(IOUT,RESP,MODOUT,MODTAB,TRANX,PATHX)
C						Do the atmospheric correction
	CALL GRADCAL(IN,IOUT,ISL,NL,TRANX,PATHX)
C								Close datasets
	CALL XVCLOSE(IN,ISTAT,' ')
	CALL XVCLOSE(IOUT,ISTAT,' ')
	RETURN
	END
C*******************************************************************************
	SUBROUTINE GET_MODTRAN_INPUT(MODINP,FULLFILE,TABFILE)
	CHARACTER*80 MODINP,FULLFILE,TABFILE
C
	PARAMETER(LAYDIM=61,NSPECX=13,NZCLD=16,NAER=7,NWAVLN=47)
	COMMON /MODPARS/H2O,O3,CH4,SO2,TEMPADJ,MODEL,M1,M2,M3,M4,M5,M6,
     +		MDEF,TBOUND,CO2MIX,IHAZE,ISEASN,IVULCN,ICSTL,VIS,WSS,
     +		WHH,H1,H2,ML,IRD1,IRD2,TITLE,ZMDL,P,T,WMOL,XMOL,JCHAR,
     +		JCHARX,AHAZE,EQLWCZ,IHA1,IVUL1,ISEA1,ICHR1,IPARM,IPH,
     +		IDAY,PARM1,PARM2,PARM3,PARM4,TIME,G
	REAL ZMDL(LAYDIM),P(LAYDIM),T(LAYDIM),AHAZE(LAYDIM)
	REAL WMOL(12,LAYDIM),XMOL(NSPECX,LAYDIM),EQLWCZ(LAYDIM)
	INTEGER IHA1(LAYDIM),IVUL1(LAYDIM),ISEA1(LAYDIM),ICHR1(LAYDIM)
	CHARACTER*4 TITLE(16)
	CHARACTER*1 JCHAR(15,LAYDIM),JCHARX(LAYDIM)
C
	REAL HOLD(NSPECX),RRATZ(LAYDIM),AWCCON(4)
	REAL WAVLEN(NWAVLN),VX(NWAVLN),EXTC(NAER,NWAVLN)
	REAL ABSC(NAER,NWAVLN),ASYM(NAER,NWAVLN),ANGF(50),F(4,50)
	REAL ZCLD(NZCLD),CLD(NZCLD),CLDICE(NZCLD),RR(NZCLD)
	INTEGER ICLD1(LAYDIM),IREG(4)
	CHARACTER*8 DLIMIT
	CHARACTER*4 TITLE2D(18,4)
	CHARACTER*1 YFLAG,XFLAG,CODE
	LOGICAL LDISORT,LSUN1
C								    open dataset
	OPEN (UNIT=81,FILE=MODINP,STATUS='OLD')
C                                                                       Card 1
	READ (81,100) CODE,MODEL,ITYPE,IEMSCT,IMULT,M1,M2,M3,M4,M5,M6,
     +		      MDEF,IM,NOPRNT,TBOUND,SALB
  100	FORMAT(A1,I4,12I5,F8.3,F7.2)
C									Card 1A
	READ (81,120) LDISORT,ISTRM,LSUN1,ISUN,CO2MIX
  120	FORMAT(L1,I4,L1,I4,F10.3)
C                                                                       Card 2
	READ (81,200) IHAZE,ISEASN,IVULCN,ICSTL,ICLD,IVSA,VIS,WSS,WHH,
     +		      RAINRT,GNDALT
  200	FORMAT(6I5,5F10.3)
C                                                                       Card 2A
	IF (ICLD.GE.18) READ (81,210) CTHIK,CALT,CEXT,ISEED
  210	FORMAT(3F8.3,2I4,6F8.3)
	IF (ICLD.GE.1 .AND. ICLD.LE.10) READ (81,210) CTHIK,CALT,CEXT,
     +		NCRALT,NCRSPC,CWAVLN,CCOLWD,CCOLIP,CHUMID,ASYMWD,ASYMIP
C                                                                       Card 2B
	IF (IVSA.EQ.1) READ (81,220) ZCVSA,ZTVSA,ZINVSA
  220	FORMAT(3F10.3)
C                                                                       Card 2C
	IF (IM.EQ.1 .AND. (MODEL.EQ.0 .OR. MODEL.EQ.7)) THEN
	    READ (81,230) ML,IRD1,IRD2,TITLE
  230	    FORMAT(3I5,18A4)
	    DO I=1,ML
C                                                                       Card 2C1
		READ (81,240) ZMDL(I),P(I),T(I),WMOL(1,I),WMOL(2,I),
     +                    WMOL(3,I),JCHAR(1,I),JCHAR(2,I),JCHAR(3,I),
     +                    JCHAR(4,I),JCHAR(5,I),JCHAR(6,I),JCHAR(7,I),
     +                    JCHAR(8,I),JCHAR(9,I),JCHAR(10,I),JCHAR(11,I),
     +                    JCHAR(12,I),JCHAR(13,I),JCHAR(14,I),
     +                    JCHAR(15,I),JCHARX(I)
  240		FORMAT(F10.3,5E10.3,15A1,A1)
C
		IF (IRD1.EQ.1) THEN
C                                                                       Card 2C2
		    READ (81,250) WMOL(4,I),WMOL(5,I),WMOL(6,I),
     +			 	  WMOL(7,I),WMOL(8,I),WMOL(9,I),
     +				  WMOL(10,I),WMOL(11,I),WMOL(12,I)
  250		    FORMAT(8E10.3)
		    IF (MDEF .EQ. 2) THEN
C									Card 2CX
			READ (81,250) (HOLD(J),J=1,NSPECX)
			DO J=1,NSPECX
			    XMOL(J,I) = HOLD(J)
			END DO
		    END IF
		END IF
C                                                                       Card 2C3
		IF (IRD2.EQ.1) READ (81,260) AHAZE(I),EQLWCZ(I),
     +					     RRATZ(I),IHA1(I),ICLD1(I),
     +					     IVUL1(I),ISEA1(I),ICHR1(I)
  260		FORMAT(10X,3F10.3,5I5)
	    END DO
	END IF
C                                                                       Card 2D
	IF (IHAZE.EQ.7 .OR. ICLD.EQ.11) THEN
	    READ (81,280) IREG
  280	    FORMAT(4I5)
	    DO I=1,4
		IF (IREG(I).NE.0) THEN
C                                                                       Card 2D1
		    READ (81,283) AWCCON(I),(TITLE2D(J,I), J=1,17)
  283		    FORMAT(E10.3,17A4)
		    TITLE2D(18,I) = '    '
C                                                                       Card 2D2
		    READ (81,285) (VX(J),EXTC(I,J),ABSC(I,J),ASYM(I,J),
     +				  J=1,NWAVLN)
  285		    FORMAT(3(F6.2,2F7.5,F6.4))
		END IF
	    END DO
	END IF
C
	IF (ICLD.GE.1 .AND. ICLD.LE.10) THEN
C									Card 2E1
	    IF (NCRALT .GE. 2) THEN
		DO I=1,NCRALT
		    READ (81,292) ZCLD(I),CLD(I),CLDICE(I),RR(I)
  292		    FORMAT(4F10.5)
		END DO
	    END IF
C									Card 2E2
	    IF (NCRSPC .GE. 2) THEN
		DO I=1,NCRSPC
		    READ (81,296) WAVLEN(I),EXTC(6,I),ABSC(6,I),
     +				 ASYM(6,I),EXTC(7,I),ABSC(7,I),ASYM(7,I)
  296		    FORMAT(7F10.5)
		END DO
	    END IF
	END IF
C
	IF (IEMSCT.EQ.3) THEN
C                                                                       Card 3
C                                                                    (Alternate)
	    READ (81,300) H1,H2,ANGLE,IDAY,RO,ISOURC,ANGLEM
  300	    FORMAT(3F10.3,I5,5X,F10.3,I5,F10.3)
	ELSE
C                                                                       Card 3
	    READ (81,310) H1,H2,ANGLE,RANGE,BETA,RO,LEN,PHI
  310	    FORMAT(6F10.5,I5,5X,F10.5)
	    IF (IEMSCT.EQ.2) THEN
C                                                                       Card 3A1
		READ (81,320) IPARM,IPH,IDAY,ISOURC
  320		FORMAT(4I5)
C                                                                       Card 3A2
		READ(81,330) PARM1,PARM2,PARM3,PARM4,TIME,PSIPO,ANGLEM,G
  330		FORMAT(8F10.3)
		IF (IPH.EQ.1) THEN
C                                                                       Card 3B1
		    READ (81,340) NANGLS
  340		    FORMAT(I5)
		    DO I=1,NANGLS
C                                                                       Card 3B2
			READ(81,350) ANGF(I),F(1,I),F(2,I),F(3,I),F(4,I)
  350			FORMAT(5E10.3)
		    END DO
		END IF
	    END IF
	END IF
C                                                                       Card 4
	READ (81,400) IV1,IV2,IDV,IRES,YFLAG,XFLAG,DLIMIT
  400	FORMAT(4I10,2A1,A8)
C                                                                       Card 5
	READ (81,500) IRPT
  500	FORMAT(I5)
C                                                                 Rescaling Card
	H2O = 1.0
	CO2 = 1.0
	O3 = 1.0
	O2 = 1.0
	CH4 = 1.0
	SO2 = 1.0
	TEMPADJ = 0.0
	READ (81,600,END=690) H2O,CO2,O3,O2,CH4,SO2,TEMPADJ
  600	FORMAT(7F10.3)
C								  filenames card
	CALL READ_FILENAMES(FULLFILE,TABFILE)
C
  690	CONTINUE
	IF (CO2 .LE. 0.0) CO2 = 1.0E-20
	IF (CO2MIX .LE. 0.0) CO2MIX = 330.0
	CO2MIX = CO2MIX * CO2
C
	CLOSE(81)
	RETURN
	END
C*******************************************************************************
	SUBROUTINE READ_FILENAMES(FULLFILE,TABFILE)
C
	CHARACTER*140 TEXT
	CHARACTER*80 FULLFILE,TABFILE,IGNORE,GET_FILENAME
C							read a card
  100	CONTINUE
	READ (81,200,END=800) TEXT
  200	FORMAT(A139)
	LOC = 1
C							scan for keywords
	DO WHILE (LOC .LE. 140)
	    IF (TEXT(LOC:LOC) .EQ. 'F' .OR. TEXT(LOC:LOC) .EQ. 'f') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'UL' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'ul') THEN
C								       FULL file
		    LOC = LOC + 2
		    FULLFILE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF(TEXT(LOC:LOC).EQ.'T' .OR. TEXT(LOC:LOC).EQ.'t') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'AB' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'ab') THEN
C									TAB file
		    LOC = LOC + 2
		    TABFILE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF(TEXT(LOC:LOC).EQ.'P' .OR. TEXT(LOC:LOC).EQ.'p') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'LT' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'lt') THEN
C								      PLTAB file
		    LOC = LOC + 2
		    IGNORE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF (TEXT(LOC:LOC).EQ.'S' .OR. TEXT(LOC:LOC).EQ.'s') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'UN' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'un') THEN
C									SUN file
		    LOC = LOC + 2
		    IGNORE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF(TEXT(LOC:LOC).EQ.'R' .OR. TEXT(LOC:LOC).EQ.'r') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'EF' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'ef') THEN
C								       REFL file
		    LOC = LOC + 2
		    IGNORE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF(TEXT(LOC:LOC).EQ.'D' .OR. TEXT(LOC:LOC).EQ.'d') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'IR' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'ir') THEN
C								      DIRAC file
		    LOC = LOC + 2
		    IGNORE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF (TEXT(LOC:LOC).EQ.'U' .OR. TEXT(LOC:LOC).EQ.'u') THEN
		LOC = LOC + 1
		LOC1 = LOC + 1
		IF (TEXT(LOC:LOC1) .EQ. 'FT' .OR.
     +		    TEXT(LOC:LOC1) .EQ. 'ft') THEN
C								     UFTAPX file
		    LOC = LOC + 2
		    IGNORE = GET_FILENAME(TEXT,LOC)
		END IF
	    ELSE IF (TEXT(LOC:LOC) .EQ. '+') THEN
C							       continuation mark
		GO TO 100
	    END IF
	    LOC = LOC + 1
	END DO
C								normal return
  800	CONTINUE
	RETURN
	END
C*******************************************************************************
	CHARACTER*80 FUNCTION GET_FILENAME(TEXT,LOC)
C
C	This routine searches for a filename in the string TEXT starting at
C	the character position LOC.  LOC is updated to point to the first
C	non-delimiting character that follows the file name.
C
	CHARACTER*140 TEXT
	CHARACTER*80 FILENAME
C						space forward to the delimiter
	N = LOC
	DO WHILE (N .LE. 140)
	    IF (TEXT(N:N) .EQ. ' ' .OR. TEXT(N:N) .EQ. ',' .OR.
     +					TEXT(N:N) .EQ. '=') THEN
		N = N + 1
		GO TO 100
	    ELSE
		N = N + 1
	    END IF
	END DO
C						get rid of extra delimiters
  100	CONTINUE
	DO WHILE (N.LE.140 .AND. (TEXT(N:N).EQ.' ' .OR. TEXT(N:N).EQ.'='
     + 				  .OR. TEXT(N:N) .EQ. ','))
	    N = N + 1
	END DO
C						capture the filename
	I = 0
	DO WHILE (N .LE. 140)
	    IF (TEXT(N:N).EQ.'"' .OR. TEXT(N:N).EQ.'''') THEN
		N = N + 1
	    ELSE IF (TEXT(N:N).EQ.' ' .OR. TEXT(N:N).EQ.',')THEN
		N = N + 1
		GO TO 300
	    ELSE IF (TEXT(N:N) .EQ. '+') THEN
		GO TO 400
	    ELSE
		I = I + 1
		FILENAME(I:I) = TEXT(N:N)
		N = N + 1
	    END IF
	END DO
C						get rid of trailing delimiters
  300	CONTINUE
	DO WHILE (N .LE. 140 .AND.
     +			(TEXT(N:N) .EQ. ' ' .OR. TEXT(N:N) .EQ. ','))
	    N = N + 1
	END DO
  400	CONTINUE
	GET_FILENAME = FILENAME(1:I)
	LOC = N - 1
	RETURN
	END
C****************************************************************************
	SUBROUTINE REPORT_MODTRAN_PARMS(MODOUT,MODTAB)
C
	CHARACTER*80 MODOUT,MODTAB
C
	PARAMETER(LAYDIM=61,NSPECX=13,NZCLD=16,NAER=7,NWAVLN=47)
	COMMON /MODPARS/H2O,O3,CH4,SO2,TEMPADJ,MODEL,M1,M2,M3,M4,M5,M6,
     +		MDEF,TBOUND,CO2MIX,IHAZE,ISEASN,IVULCN,ICSTL,VIS,WSS,
     +		WHH,H1,H2,ML,IRD1,IRD2,TITLE,ZMDL,P,T,WMOL,XMOL,JCHAR,
     +		JCHARX,AHAZE,EQLWCZ,IHA1,IVUL1,ISEA1,ICHR1,IPARM,IPH,
     +		IDAY,PARM1,PARM2,PARM3,PARM4,TIME,G
	REAL ZMDL(LAYDIM),P(LAYDIM),T(LAYDIM),AHAZE(LAYDIM)
	REAL WMOL(12,LAYDIM),XMOL(NSPECX,LAYDIM),EQLWCZ(LAYDIM)
	INTEGER IHA1(LAYDIM),IVUL1(LAYDIM),ISEA1(LAYDIM),ICHR1(LAYDIM)
	CHARACTER*4 TITLE(16)
	CHARACTER*1 JCHAR(15,LAYDIM),JCHARX(LAYDIM)
C
	CHARACTER*132 BUF
C
	CHARACTER*44 MODEL_NAME(7)
     +      /' TROPICAL TEMPERATURE AND PRESSURE          ',
     +       ' MIDLATITUDE SUMMER TEMPERATURE AND PRESSURE',
     +       ' MIDLATITUDE WINTER TEMPERATURE AND PRESSURE',
     +       ' SUBARCTIC SUMMER TEMPERATURE AND PRESSURE  ',
     +       ' SUBARCTIC WINTER TEMPERATURE AND PRESSURE  ',
     +       ' 1976 U.S. STANDARD ATMOSPHERE              ',
     +       ' USER SPECIFIED ATMOSPHERIC MODEL           '/
C
	CHARACTER*50 M2_NAME(6)
     +      /' TROPICAL WATER VAPOR PROFILE                     ',
     +       ' MIDLATITUDE SUMMER WATER VAPOR PROFILE           ',
     +       ' MIDLATITUDE WINTER WATER VAPOR PROFILE           ',
     +       ' SUBARCTIC SUMMER WATER VAPOR PROFILE             ',
     +       ' SUBARCTIC WINTER WATER VAPOR PROFILE             ',
     +       ' 1976 U.S. STANDARD ATMOSPHERE WATER VAPOR PROFILE'/
C
	CHARACTER*44 M3_NAME(6)
     +      /' TROPICAL OZONE PROFILE                     ',
     +       ' MIDLATITUDE SUMMER OZONE PROFILE           ',
     +       ' MIDLATITUDE WINTER OZONE PROFILE           ',
     +       ' SUBARCTIC SUMMER OZONE PROFILE             ',
     +       ' SUBARCTIC WINTER OZONE PROFILE             ',
     +       ' 1976 U.S. STANDARD ATMOSPHERE OZONE PROFILE'/
C
	CHARACTER*43 IHAZE_NAME(9)
     +	    /' RURAL AEROSOLS, VISIBILITY - 23 KM.       ',
     +       ' RURAL AEROSOLS, VISIBILITY - 5 KM.        ',
     +       ' NAVY MARITIME AEROSOL ATTENUATION         ',
     +       ' MARITIME AEROSOLS, VISIBILITY - 23 KM.    ',
     +       ' URBAN AEROSOLS, VISIBILITY - 5 KM.        ',
     +       ' TROPOSPHERIC AEROSOLS, VISIBILITY - 50 KM.',
     +       ' INVALID AEROSOL OPTION                    ',
     +       ' ADVECTION FOG, VISIBILITY - 0.2 KM.       ',
     +       ' RADIATION FOG, VISIBILITY - 0.5 KM.       '/
C
 	IF (MODEL.EQ.7 .AND. H2.LT.ZMDL(1)) THEN
	    CALL XVMESSAGE('The lowest atmospheric layer must be',' ')
	    CALL XVMESSAGE(
     +	      'at least as low as the ground elevation value',' ')
	    CALL ABEND
 	END IF
C
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE('       ***MODTRAN PARAMETERS***',' ')
	IF (M1.EQ.0) THEN
	    CALL XVMESSAGE(MODEL_NAME(MODEL),' ')
	ELSE
	    CALL XVMESSAGE(MODEL_NAME(M1),' ')
	END IF
	IF (MODEL.EQ.7) THEN
	    CALL XVMESSAGE('   ALTITUDE  PRESSURE    TEMP    WATER',' ')
	    DO I=1,ML
		WRITE (BUF,100) ZMDL(I),P(I),T(I),WMOL(1,I),
     +				(JCHAR(J,I),J=1,15),JCHARX(I)
  100		FORMAT(F10.3,3F10.2,5X,15A1,2X,A1)
		CALL XVMESSAGE(BUF,' ')
	    END DO
	ELSE
	    CALL XVMESSAGE(M2_NAME(M2),' ')
	    CALL XVMESSAGE(M3_NAME(M3),' ')
	END IF
C
	WRITE (BUF,110) H2O
  110	FORMAT(' Water Rescaling Factor =',F6.3)
	CALL XVMESSAGE(BUF,' ')
C
	WRITE (BUF,120) O3
  120	FORMAT(' Ozone Rescaling Factor =',F6.3)
	CALL XVMESSAGE(BUF,' ')
C
	WRITE (BUF,130) CH4
  130	FORMAT(' Methane Rescaling Factor =',F6.3)
	CALL XVMESSAGE(BUF,' ')
C
	WRITE (BUF,140) SO2
  140	FORMAT(' Sulfur Dioxide Rescaling Factor =',F6.3)
	CALL XVMESSAGE(BUF,' ')
C
	WRITE (BUF,150) CO2MIX
  150	FORMAT(' Carbon Dioxide Mixing Ratio =',F8.2,' ppm')
	CALL XVMESSAGE(BUF,' ')
C
	IF (TEMPADJ .NE. 0.0) THEN
	    WRITE (BUF,155) TEMPADJ
  155	    FORMAT(' Temperature Adjustment =',F6.2,' degrees Celsius')
	    CALL XVMESSAGE(BUF,' ')
	END IF
C
	IF (IHAZE.GT.0) THEN
	    CALL XVMESSAGE(IHAZE_NAME(IHAZE),' ')
	    IF (VIS .NE. 0.0) THEN
		WRITE (BUF,160) VIS
  160		FORMAT(' Visibility set to ',F7.2,' km.')
		CALL XVMESSAGE(BUF,' ')
	    END IF
	ELSE
	    CALL XVMESSAGE(' No boundary layer aerosol attenuation',' ')
	END IF
C
	WRITE (BUF,200) H1
  200	FORMAT(' Sensor Altitude =',F9.3,' km')
	CALL XVMESSAGE(BUF,' ')
C
	WRITE (BUF,210) H2
  210	FORMAT(' Target Altitude =',F9.3,' km')
	CALL XVMESSAGE(BUF,' ')
C
	IF (MODOUT .NE. 'dummy') THEN
	    WRITE (BUF,300) MODOUT
  300	    FORMAT(' MODTRAN report file is stored in ',A80)
	    CALL XVMESSAGE(BUF,' ')
	END IF
C
	IF (MODTAB .NE. 'dummy') THEN
	    WRITE (BUF,310) MODTAB
  310	    FORMAT(' MODTRAN tabular file is stored in ',A80)
	    CALL XVMESSAGE(BUF,' ')
	END IF
C
	CALL XVMESSAGE(' ',' ')
	RETURN
	END
C***********************************************************************
	SUBROUTINE MODTRAN_INTERFACE(IOUT,RESP,MODOUT,MODTAB,TRANX,
     +				     PATHX)
C
	REAL RESP(800,10),TRANX(716,10),PATHX(716,10)
	CHARACTER*80 MODOUT,MODTAB
C
	PARAMETER(LAYDIM=61,NSPECX=13,NZCLD=16,NAER=7,NWAVLN=47)
	COMMON /MODPARS/H2O,O3,CH4,SO2,TEMPADJ,MODEL,M1,M2,M3,M4,M5,M6,
     +		MDEF,TBOUND,CO2MIX,IHAZE,ISEASN,IVULCN,ICSTL,VIS,WSS,
     +		WHH,H1,H2,ML,IRD1,IRD2,TITLE,ZMDL,P,T,WMOL,XMOL,JCHAR,
     +		JCHARX,AHAZE,EQLWCZ,IHA1,IVUL1,ISEA1,ICHR1,IPARM,IPH,
     +		IDAY,PARM1,PARM2,PARM3,PARM4,TIME,G
	REAL ZMDL(LAYDIM),P(LAYDIM),T(LAYDIM),AHAZE(LAYDIM)
	REAL WMOL(12,LAYDIM),XMOL(NSPECX,LAYDIM),EQLWCZ(LAYDIM)
	INTEGER IHA1(LAYDIM),IVUL1(LAYDIM),ISEA1(LAYDIM),ICHR1(LAYDIM)
	CHARACTER*4 TITLE(16)
	CHARACTER*1 JCHAR(15,LAYDIM),JCHARX(LAYDIM)
C
	REAL WAVELEN(50000),TRANSMIT(50000),PATHRAD(50000),SKYRAD(50000)
	REAL SPECALB(50000),RRATZ(LAYDIM),AWCCON(4),WAVLEN(47),VX(47)
	REAL EXTC(7,47),ABSC(7,47),ASYM(7,47)
	REAL ZCLD(16),CLD(16),CLDICE(16),RR(16)
	REAL ANGF(50),F(4,50),FRAC(358),TRANS(10,2),PATH(10,2),SKY(10,2)
	INTEGER ICLD1(LAYDIM),IREG(4)
	LOGICAL LDISORT,LSUN1
	CHARACTER*80 MODLIB,PLTABFILE,SUNFILE,DIRACFILE,UFTAPXFILE,MSG
	CHARACTER*8 DLIMIT
	CHARACTER*4 TITLE2D(18,4)
	CHARACTER*1 CODE,YFLAG,XFLAG
C						  set up interpolation fractions
C						  for each sample location
	DEFL = 42.96
	DELTA = DEFL/358.0
	COSFULL = COS(DEFL*PI/180)
	DO I=1,358
	    COSI = COS(DELTA*FLOAT(I)*PI/180)
	    FRAC(I) = (COSI-COSFULL) / (COSI*(1.0-COSFULL))
	END DO
C						       declare modtran constants
	PLTABFILE = 'null'
	CALL XGETENV_VIC('VICARMODTRAN35',MODLIB)
	SUNFILE = MODLIB(1:LNBLNK(MODLIB)) // '/sun3'
	DIRACFILE = MODLIB(1:LNBLNK(MODLIB)) // '/MOLBMP96.BIN'
	UFTAPXFILE = MODLIB(1:LNBLNK(MODLIB)) // '/CFCBMP96.ASC'
	O2 = 1.0
	CODE = 'T'
	ITYPE = 2
	IEMSCT = 1
	IMULT = 1
	IF (MODEL .EQ. 7) THEN
	    IM = 1
	ELSE
	    IM = 0
	END IF
	NOPRNT = 0
	DO I=1,50000
	    SPECALB(I) = 0.05
	END DO
	LDISORT = .FALSE.
	ISTRM = 0
	LSUN1 = .TRUE.
	ISUN = 5
	ICLD = 0
	IVSA = 0
	RAINRT = 0.0
	GNDALT = H2
	RANGE = 0.0
	BETA = 0.0
	RO = 0.0
	LEN = 0
	PHI = 0.0
	IV1 = 601
	IV2 = 1500
	IDV = 1
	IRES = 2
	YFLAG = ' '
	XFLAG = ' '
	IF (IRD2 .NE. 0) THEN
	    DO I=1,ML
		RRATZ(I) = 0.0
		ICLD1(I) = 0
	    END DO
	END IF
	ANGLE = 180.0
C						       run MODTRAN at two angles
	DO IANGLE=1,2
	    CALL MODTRAN3(MODOUT,MODTAB,PLTABFILE,SUNFILE,DIRACFILE,
     +		UFTAPXFILE,H2O,O3,O2,CH4,SO2,TEMPADJ,CODE,MODEL,ITYPE,
     +		IEMSCT,IMULT,M1,M2,M3,M4,M5,M6,MDEF,IM,NOPRNT,
     +		TBOUND,SPECALB,LDISORT,ISTRM,LSUN1,ISUN,CO2MIX,
     +		IHAZE,ISEASN,IVULCN,ICSTL,ICLD,IVSA,VIS,WSS,WHH,
     +		RAINRT,GNDALT,H1,H2,ANGLE,RANGE,BETA,RO,LEN,PHI,
     +		IV1,IV2,IDV,IRES,YFLAG,XFLAG,DLIMIT,CTHIK,CALT,
     +		CEXT,ISEED,NCRALT,NCRSPC,CWAVLN,CCOLWD,CCOLIP,
     +		CHUMID,ASYMWD,ASYMIP,ZCVSA,ZTVSA,ZINVSA,ML,IRD1,
     +		IRD2,TITLE,ZMDL,P,T,WMOL,XMOL,JCHAR,JCHARX,
     +		AHAZE,EQLWCZ,RRATZ,IHA1,ICLD1,IVUL1,ISEA1,ICHR1,
     +		IREG,AWCCON,TITLE2D,WAVLEN,VX,EXTC,ABSC,ASYM,
     +		ZCLD,CLD,CLDICE,RR,IPARM,IPH,IDAY,ISOURC,PARM1,
     +		PARM2,PARM3,PARM4,TIME,PSIPO,ANGLEM,G,NANGLS,
     +		ANGF,F,WAVELEN,TRANSMIT,PATHRAD,SKYRAD)
C
	    CALL WVNUM2WVLEN(TRANSMIT,PATHRAD,SKYRAD)
C
C					Compute the transmittance, path radiance
C					and sky radiance for each channel by
C					multiplying the per wavenumber values by
C					the 10 normalized response functions.
	    DO ICHAN=1,10
		TRANS(ICHAN,IANGLE) = 0.0
		PATH(ICHAN,IANGLE) = 0.0
		SKY(ICHAN,IANGLE) = 0.0
		DO IWAVE=1,800
		    TRANS(ICHAN,IANGLE) = TRANS(ICHAN,IANGLE) +
     +			 	       RESP(IWAVE,ICHAN)*TRANSMIT(IWAVE)
		    PATH(ICHAN,IANGLE) = PATH(ICHAN,IANGLE) +
     +					RESP(IWAVE,ICHAN)*PATHRAD(IWAVE)
		    SKY(ICHAN,IANGLE) = SKY(ICHAN,IANGLE) +
     +					RESP(IWAVE,ICHAN)*SKYRAD(IWAVE)
		END DO
C					      Change units from W/cm^2 to mW/m^2
C
		PATH(ICHAN,IANGLE) = 1.0E7 * PATH(ICHAN,IANGLE)
		SKY(ICHAN,IANGLE) = 1.0E7 * SKY(ICHAN,IANGLE)
C						      to prevent division by 0.0
		IF (TRANS(ICHAN,IANGLE).LE.0.0) TRANS(ICHAN,IANGLE)=1.0
	    END DO
C					    update params for second modtran run
	    MODOUT = 'dummy'
	    MODTAB = 'dummy'
	    ANGLE = 180.0 - DEFL
	END DO
C					  put sky radiance values in VICAR label
	CALL XLADD(IOUT,'HISTORY','SKY41',SKY(1,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY42',SKY(2,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY43',SKY(3,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY44',SKY(4,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY45',SKY(5,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY46',SKY(6,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY47',SKY(7,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY48',SKY(8,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY49',SKY(9,1),ISTAT,
     +		   'FORMAT','REAL',' ')
	CALL XLADD(IOUT,'HISTORY','SKY50',SKY(10,1),ISTAT,
     +		   'FORMAT','REAL',' ')
C					     interpolate transmittance and path
C					     radiance to a value for each sample
	DO ICHAN=1,10
	    DO I=1,358
		TRANX(358+I,ICHAN) = FRAC(I)*TRANS(ICHAN,1) +
     +				     (1.0-FRAC(I))*TRANS(ICHAN,2)
		PATHX(358+I,ICHAN) = FRAC(I)*PATH(ICHAN,1) +
     +				     (1.0-FRAC(I))*PATH(ICHAN,2)
		TRANX(359-I,ICHAN) = TRANX(358+I,ICHAN)
		PATHX(359-I,ICHAN) = PATHX(358+I,ICHAN)
	    END DO
	END DO
C							      report the relults
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(
     +'          Transmittance      Path  Radiance      Sky Radiance',
     +' ')
	CALL XVMESSAGE(
     +'                             (mW/m**2/sr/u)       (mW/m**2/u)',
     +' ')
	CALL XVMESSAGE(
     +' Band   Nadir   Off-nadir   Nadir   Off-nadir',' ')
	DO ICHAN=1,10
	    WRITE (MSG,500) ICHAN+40,TRANS(ICHAN,1),TRANS(ICHAN,2),
     +			    PATH(ICHAN,1),PATH(ICHAN,2),SKY(ICHAN,1)
  500	    FORMAT(I4,F10.5,F9.5,F11.1,F9.1,F15.1)
	    CALL XVMESSAGE(MSG,' ')
	END DO
C
	RETURN
	END
C****************************************************************************
	SUBROUTINE WVNUM2WVLEN(TRANSMIT,PATHRAD,SKYRAD)
C
C	This routine takes the arrays returned from MODTRAN (900 elements,
C	from 601 to 1500 wavenumbers), and returns arrays that are indexed
C	in wavelength intervals (800 elements, from 7.00 to 14.99 micrometers).
C
	REAL TRANSMIT(900),PATHRAD(900),SKYRAD(900)
	REAL TR(1500),PATH(1500),SKY(1500)
C
	DO I=1,900
	    TR(I+600) = TRANSMIT(I)
	    PATH(I+600) = PATHRAD(I)
	    SKY(I+600) = SKYRAD(I)
	END DO
C
	DO I=1,800
	    WAVELENGTH = FLOAT(I+699) / 100.0
	    WAVENUM = 10000.0 / WAVELENGTH
	    INDEX = INT(WAVENUM)
	    FRAC = WAVENUM - FLOAT(INDEX)
	    TRANSMIT(I) = (1.0-FRAC)*TR(INDEX) + FRAC*TR(INDEX+1)
	    PATHRAD(I) = (1.0-FRAC)*PATH(INDEX) + FRAC*PATH(INDEX+1)
	    SKYRAD(I) = (1.0-FRAC)*SKY(INDEX) + FRAC*SKY(INDEX+1)
	END DO
C
	RETURN
	END
C****************************************************************************
	SUBROUTINE GRADCAL(IN,IOUT,ISL,NL,TRANX,PATHX)
C
	REAL TRANX(716,10),PATHX(716,10),BUF(716)
	INTEGER OUTBUF(716)
C
	DO ICHAN=1,10
	    DO ILINE=ISL,ISL+NL-1
		CALL XVREAD(IN,BUF,ISTAT,'LINE',ILINE,'BAND',ICHAN,' ')
		DO J=1,716
		    OUTBUF(J) = NINT((1000.0*BUF(J)-PATHX(J,ICHAN)) /
     +				TRANX(J,ICHAN))
		END DO
		CALL XVWRIT(IOUT,OUTBUF,ISTAT,' ')
	    END DO
	END DO
	RETURN
	END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
      SUBROUTINE DIRREA (ARRAY,LNG)
C     READ DIRECT-FILE
C     2022-02-05: formal parms DECB, FDIR4 -> COMMON
C     GF 24.08.1980
C
      INCLUDE 'PARS.f'
      INCLUDE 'DIRS.f'
      INTEGER*2 PARASK
      INTEGER*2 I
     = ,LNG      ! NUMBER OF ELEMENTS IN 'ARRAY'
     = ,ARRAY(1) ! TRANSMIT FROM/TO THIS ARRAY
C
      HIGH = 0
1     CONTINUE
        HIGH = HIGH + DIRHIB
        IF (HIGH .LE. LNG) GOTO 6
C         HERE IS 'HIGH .GT. LNG' - DUPLICATE SOME ELEMENTS
          HIGH = LNG
6       CONTINUE
        LOW = HIGH - DIRHIB + 1
        IF (LOW .LT. 0)
     =    CALL ASSERT (162,LNG,DIRHIB)
        READ  (UDIR, rec=FDIR) (ARRAY(I),I=LOW,HIGH)
        FDIR = FDIR + 1
      IF (HIGH .LT. LNG) GOTO 1
      RETURN
      END

ext: f

max_stars_repo_name: gfis/jextra

max_issues_repo_name: gfis/jextra

max_forks_repo_name: gfis/jextra


text:
Debats du Senat (hansard)
1ere Session, 36e Legislature,
Volume 137, Numero 55
Le mercredi 29 avril 1998
L'honorable Gildas L. Molgat, President
L'interruption de l'automatisation des phares en Colombie-Britannique
Le service de traversier entre Terre-Neuve et le continent
Les problemes de financement de Telefilm Canada
terrorisme et securite publique
La selection des membres du comite special
La taxe sur les produits et services
L'abolition de la taxe sur les imprimes-Presentation de petitions
Le remplacement des helicopteres Sea King-La position du gouvernement
L'importance de projections financieres a plus long terme-La position du gouvernement
L'efficacite des projections financieres-La position du gouvernement
La prolongation du mandat du titulaire actuel-La position du gouvernement
Reponses differees a des questions orales
Les enfants comme protagonistes dans la guerre en Ouganda-La position du gouvernement
La Loi sur la reorganisation et l'alienation de Teleglobe Canada
Projet de loi modificatif-Troisieme lecture
La position de la Colombie-Britannique sur le statut du Quebec-Interpellation
L'Association parlementaire Canada-Europe
La reunion du Conseil de l'Europe a Strasbourg, en France-Interpellation
Le mercredi 29 avril 1998
La seance est ouverte a 14 heures, le President etant au fauteuil.
C'etait vraiment l'ecrivain le plus eloquent des Prairies.
Il s'agit d'une nouvelle compilation de ses ecrits.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Honorables senateurs, je pense que la seule reponse appropriee est Touche.
L'interruption de l'automatisation des phares en Colombie-Britannique
L'honorable John Lynch-Staunton (chef de l'opposition) :
Puis, le gouvernement liberal a renverse cette decision et le retrait du personnel a commence.
Elle le merite bien.
L'honorable Philippe Deane Gigantes :
Vous la voyez mieux maintenant avec sa flamme rouge.
Eh bien, les gens ont aussi vote pour M. Manning.
Un officier a ete accuse a tort, sans preuve, par la commission d'enquete.
Le service de traversier entre Terre-Neuve et le continent
L'honorable P. Derek Lewis :
Premierement, je voudrais rappeler certains faits historiques.
Ces deux dispositions figurent dans la Loi sur Terre-Neuve de 1949.
J'espere que ce sera le cas.
Les problemes de financement de Telefilm Canada
De nombreuses emissions risquent de devoir etre annulees au cours des prochaines saisons.
Quelle logique preside a l'exploitation du fonds de 200 millions de dollars?
Peu de professionnels de la television pensent que ces objectifs puissent etre concilies.
Qu'arrivera-t-il l'an prochain?
Est-ce que les criteres de selection sont rationnels?
D'ailleurs, quels sont les objectifs a long terme de ce ministere?
terrorisme et securite publique
La selection des membres du comite special
L'honorable William M. Kelly :
Son Honneur le President :
Permission accordee, honorables senateurs?
L'honorable Marcel Prud'homme :
Honorables senateurs, vous vous souviendrez que j'avais appuye cette motion.
Je pourrais donner tout un spectacle, mais cela ne menerait a rien.
Je me rends en Alberta donner un discours sur le Senat.
Ce pourrait etre mon sujet.
Nous n'avons pas encore regle le probleme des senateurs qui veulent participer.
Il suffit de consulter la liste pour voir de quels comites ces senateurs font partie.
Je ne peux repondre a cette question.
Je me ronge les sangs.
Combien de senateurs n'ont pas peur des medias?
J'espere avoir dit cela comme il faut.
Certains ne semblent pas comprendre que le pays fait face a une attaque.
Ne vous faites pas d'illusions au sujet du changement qui se produit au Quebec.
Cependant, que faites-vous?
Vous multipliez le travail de certains senateurs.
Nous en avons parle hier.
Vous voulez reduire le nombre de senateurs siegeant aux comites du Senat.
J'espere que je ne devoile pas un secret.
Je ne demande pas votre protection.
Cependant, je pense que c'est injuste.
Que se passe-t-il donc?
Vous avez tous l'air surpris.
Le leader du Senat a approuve cela.
Il connait l'interet que je porte a certaines questions, notamment les affaires etrangeres.
J'ai siege a l'autre endroit pendant 30 ans.
Ne voulons-nous pas que certains senateurs apportent leur contribution?
Les anciens combattants de tout le pays etaient vraiment furieux contre le gouvernement.
La taxe sur les produits et services
L'abolition de la taxe sur les imprimes-Presentation de petitions
L'honorable Consiglio Di Nino :
Ces petitions sont particulierement judicieuses compte tenu de l'eloquente declaration du senateur Fairbairn.
Le remplacement des helicopteres Sea King-La position du gouvernement
L'honorable J. Michael Forrestall :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Les 15 autres attendent dans le hangar qu'on leur fasse la meme chose.
Quand y aurat-il un appel d'offres pour le remplacement des Sea King?
L'honorable B. Alasdair Graham (leader du gouvernement) :
En guise de question supplementaire, je demande une clarification.
Le ministre peut-il nous donner une idee des delais impartis?
Je regrette de vous decevoir sur ce point, honorables senateurs.
Je vous transmettrai les renseignements des que je les obtiendrai.
L'importance de projections financieres a plus long terme-La position du gouvernement
En rejetant la recommandation du verificateur general, le ministere des Finances a dit ceci:
L'honorable B. Alasdair Graham (leader du gouvernement) :
Nous avons toujours adopte une approche en deux volets a cet egard.
Je suis d'accord avec cet enonce.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Je remercie l'honorable senateur Spivak d'avoir porte cette question a notre attention.
Elle est a l'etude et je vais essayer d'obtenir de plus amples renseignements.
Je sais qu'il est merveilleux d'avoir:
J'ai note tres soigneusement les 70 postes qu'on est cense offrir a Winnipeg.
L'efficacite des projections financieres-La position du gouvernement
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Le ministre des Finances n'est jamais paternaliste et il ne cache rien.
Notre gouvernement est le plus transparent de l'histoire de notre pays.
En traficotant les livres.
Jamais en traficotant les livres.
Qu'en est-il des 2,5 milliards de dollars?
Parlez-nous du regime de prestations aux aines.
L'hepatite, oui, une pleine indemnisation.
Quand des promesses sont faites et des engagements sont pris, on en prend note immediatement.
Nous les avons reveilles.
Il en va de meme de la Commission canadienne du ble.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Il existe des differences et des principes comptables...
Et la reponse a ete des plus positives.
Nous devrions verifier la transparence dans le cas de l'aeroport Pearson.
L'honorable Consiglio Di Nino :
Comme le verificateur general le souligne au chapitre 9 de son dernier rapport:
Les parlementaires devraient s'attendre a autant de la part du gouvernement.
Et sans cette certitude, la credibilite de tous les etats financiers est compromise.
L'honorable B. Alasdair Graham (leader du gouvernement) :
L'honorable John Lynch-Staunton (chef de l'opposition) :
Est-ce le cabinet Ernst & Young?
Le verificateur general fait-il erreur?
Le verificateur general est manifestement en desaccord.
Et c'est aussi la demarche la plus responsable.
Les ministeriels ne traitent-ils pas les Canadiens differemment d'eux-memes?
Absolument pas, honorables senateurs.
L'honorable senateur sait que ce n'est pas logique.
C'est base sur une decision illogique du gouvernement.
C'est votre pretention?
Cela n'a aucun bon sens.
C'est un langage d'enfants d'ecole que de parler ainsi.
Le ministre des Finances a une excellente equipe de comptables qui travaillent pour lui.
Le verificateur general le reconnaitrait, le ministre des Finances le reconnait.
Le ministre des Finances manifeste une sorte d'arrogance imperiale.
Il fixe les regles de comptabilite au Canada.
Ce n'est pas serieux!
C'est le meilleur ministre des Finances imperial que nous ayons jamais eu.
L'honorable J. Michael Forrestall :
Cela me fait penser aux compressions d'effectifs de Canada 21.
L'honorable B. Alasdair Graham (leader du gouvernement) :
La prolongation du mandat du titulaire actuel-La position du gouvernement
L'honorable Norman K. Atkins :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Je crois comprendre que la question a l'etude.
Reponses differees a des questions orales
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Les enfants comme protagonistes dans la guerre en Ouganda-La position du gouvernement
(Reponse a la question posee par l'honorableNorman K. Atkins le 25 mars 1998)
( Reponse a la question posee par l'honorable Noel A. Kinsella le 24 mars 1998 )
Elle garantit aussi l'egalite devant la loi, mais n'envisage pas une action positive.
Ce ne sont que des exemples des preoccupations ressenties a l'egard de la CADH.
En attendant, le Canada participe pleinement au systeme interamericain des droits de la personne.
La Loi sur la reorganisation et l'alienation de Teleglobe Canada
Projet de loi modificatif-Troisieme lecture
a ) a la page 1, par la suppression des lignes 4 a 12;
2. a l'article 3,
a ) a la page 1, par la suppression des lignes 22 et 23;
b ) a la page 2:
(i) par la suppression de l'intertitre precedant la ligne 1,
(ii) par la suppression des lignes 1 a 42;
c ) a la page 3, par la suppression des lignes 1 a 15;
4. a l'article 7,
a ) a la page 5, par la suppression des lignes 7 a 16;
Son Honneur le President :
Le senateur Lynch-Staunton :
Son Honneur le President :
Honorables senateurs, la motion d'amendement est rejetee a la majorite.
Plait-il aux honorables senateurs d'adopter la motion?
(La motion est adoptee, et le projet de loi, lu une troisieme fois, est adopte.)
La position de la Colombie-Britannique sur le statut du Quebec-Interpellation
L'honorable Pat Carney , conformement a l'avis du 24 mars 1998:
Le rapport contient des bonnes et des mauvaises nouvelles.
Mes paroles exactes etaient les suivantes:
La motion n'avait pas ete appuyee.
Cela represente environ70 p. 100 des lecteurs.
Les tribunes telephoniques a la radio se sont enflammees et le debat a fait rage.
Cette situation est certainement injuste.
Le gouvernement a heureusement renonce a cette politique.
Je n'ai aucun doute concernant le succes du Canada.
Je me demande si le Senat m'y autoriserait.
Son Honneur le President :
Son Honneur le President :
L'Association parlementaire Canada-Europe
La reunion du Conseil de l'Europe a Strasbourg, en France-Interpellation
L'honorable Jerahmiel S. Grafstein , ayant donne avisle 28 avril 1998:
N'y a-t-il jamais de repit?
La mission de l'Europe touche-t-elle a sa fin?
Quelles seraient les limites geographiques et politiques d'une Europe unie?,
Ou sont les Allemands?
Les Allemands furent immediatement invites a participer.
Les observations de Churchill etaient donc a la fois visionnaires et renversantes d'exactitude.
L'idee d'une nouvelle Europe est en train de naitre.
Les presidents de ces comites cles sont choisis selon l'appartenance a un parti.
Encore une fois, l'affiliation politique a joue un role.
Nous avons plus en commun que ne le croient la plupart des gens.
Ce n'est pas le temps de faire de fausses economies.
Parfois, nous ne nous entendons pas sur les principes avec les Europeens.
Par exemple, les Canadiens croient qu'il faut integrer rapidement les refugies.
Les Europeens, pour leur part, preferent accorder un statut temporaire a leurs refugies.
Par consequent, les problemes politiques couvent, se compliquent et proliferent en Europe.
Le Canada devrait etre pret.
Il doit etre sur place.
Commencons par le Conseil de l'Europe.
Honorables senateurs, il y a beaucoup de travail a faire.
Le gouvernement doit agir vite.
L'Europe bouge et nous devons bouger aussi.
Son Honneur le President :
(Le Senat s'ajourne a 14 heures demain.)


text:
Lobby Corps is an ASUCD unit that researches and analyzes pending legislation and government programs. The goal of Lobby Corps is to influence legislators and government officials in order to promote undergraduate students students views on issues that affect students as well as giving student real world political and organizing experience. Lobby Corps is most active at the California State Legislature. Many Lobby Corps alumni go on to work at the State Capitol or attend the UCDC program in Washington, DC.

Lobby Corps is always looking for undergraduate students to intern or volunteer.

Students can be involved by attending meetings, lobbying visits and other Lobby Corps activities. Meetings are currently held every Tuesday from 7:10pm8:30pm, with the current location being in the Angelina Malfitano conference room on the third floor of the Memorial Union. Meetings will feature guest speakers, discussions on legislation, as well as training on general lobby techniques.

For more information or to sign up, please contact Lobby Corps Director David Kuwabara MailTo(davidkuwabara AT gmail DOT com)

New members are always welcome!

Please follow the link to our calendar to check out our activities!
 http://www.google.com/calendar/embed?srcucdavis.edu_h71csia019t6quct3uhsisrdls%40group.calendar.google.com&ctzAmerica/Los_Angeles ASUCD Lobby Corps Calendar

2013  14 Staff Members
  David Kuwabara, Director
  Natasha Kang, Internal Director
  Sumeeta Ghai, External Director
  Stephanie Chon, Assistant External Director
  Julia Reifkind, Assistant Internal Director
  Matthew Jorgens, Field Director
  Harley Litzelman, Legislative Assistant
  Allison Butler, Communications Assistant

2013  14 Interns
  Alisha Starelli
  Samuel Conovitz
  Alexandra Sherer

Lobby Corps in the News

  http://www.universityofcalifornia.edu/regents/minutes/2005/cw1117.pdf Discussing fee buybacks.
  http://www.dailybruin.ucla.edu/news/articles.asp?id35046 Lobby the UC Regents.
  http://www.californiaaggie.com/media/paper981/news/2006/01/04/CampusNews/Proposed.Budget.To.Curb.Fee.Hike1282419.shtml?norewrite200603271241&sourcedomainwww.californiaaggie.com Discussing effect of fee increases.
  http://media.www.californiaaggie.com/media/storage/paper981/news/2007/02/27/Opinion/Guest.Opinion.Derick.Lennox2745481.shtml Discussing the effects of the 2007 UC fee increase.

 Legislation

  http://www.leginfo.ca.gov/cgibin/postquery?bill_numbersb_190&sessCUR&houseB&authoryee SB 190:Public postsecondary education:California State University: University of California: open meetings. Signed by the Governor

  http://www.leginfo.ca.gov/cgibin/postquery?bill_numberab_152&sessCUR&houseB&authorbeall AB 152: Postsecondary education: Golden State Scholarshare Trust: California Prepaid Tuition Program. Still Pending

 Keep Updated on California Politics

  http://www.leginfo.ca.gov/ Official California Legislative Information

  http://www.lao.ca.gov/ Legislative Analysts Office

  http://www.rtumble.com Rough and Tumble

  http://www.flashreport.org/ Flashreport Blog

  http://www.cppf.us/  The California Public Policy Foundation

  http://poll.gallup.com/ Gallup poll

  http://www.calnews.com/ Cal News

  http://www.capitolbasement.com/ The Round up

History

  Past Directors
   Karandev Singh (2012  2013)
   Bihter Ozedrine (2010  2011)
   Talia MacMath (20082009)
   Derick Lennox (20062008)
   Michael Caporusso (20052006)
   Brian McInnis (20042005)
   Thomas Lloyd (20032004)
   Liz Burrell (20022003)

 From 20042006 Lobby Corps was a subunit of the ASUCD Office of External Affairs(OEA). Caporusso was the director of the subunit. McInnis was director of OEA and assumed the role of Lobby Corps director during his time. After the spring 2006 OEA, under Darnell Holloways ASUCD President presidency, was broken back up into its three components of ASUCD City/County Affairs Office, ASUCD State and National Affairs Office, and Lobby Corps. When ASUCD pulled out of UCSA in November 2006, Lobby Corps and ASUCD State and National Affairs Office became the sole state and national representative for UCD students. Even though the ASUCD State and National Affairs Office used to be in charge of ASUCD dealings with UCSA, after ASUCD pulled out, this office for some reason did not know what to do with itself, which resulted in its disbandment. At that time, Lobby Corp became ASUCDs sole state and national representative for UCD students. They also receive a significant portion (roughly $15,000) of the former UCSA funds which are now used to hire a private public affairs firm to provide professional training and research.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine area_flow_bc(iflg)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Calculate areas for flow through BC
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 3.0
!D2
!D2 Initial implementation: 11-Nov-2009, Programmer: George Zyvoloski
!D2
!D2 $Log:   /pvcs.config/fehm90/src/area_flow_bc.f_a  $
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.7 Sources and sinks
!D3 2.6   Provide Input/Output Data Files
!D3 3.0   INPUT AND OUTPUT REQUIREMENTS
!D3
!***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use combi
      use comci
      use comdi
      use comdti
      use comki
      use davidi
      implicit none

      integer i,icode,iflg,neqp1,i1,i2,jj,kb
      integer i3,i4,kk,idir
      real*8 area_mult,areat,sx2c,dis,disz2,cosz,rlp_min
      real*8 cord1,cord2,cord3,cord1j,cord2j,cord3j
      real*8 dil_dum,perm
      parameter (rlp_min=1.d-2)
      dil_dum = (997./1.e-3)
      neqp1 = neq +1
      if(iflg.eq.1) then
         do i = 1, n0
            if (ka(i).eq.-23.or.ka(i).eq.-24) then
c     free drainage condition
               areat = 0.0
               area_mult = wellim(i)
               cord1 = cord(i,1)
               cord2 = cord(i,2)
               cord3 = 0.0
               if(icnl.eq.0) then
                  cord3 = cord(i,3)
               endif
               i1 = nelm(i)+1
               i2 = nelm(i+1)
               do jj = i1,i2
                  kb = nelm(jj)
                  if(kb.lt.i) then
                     i3 = nelmdg(kb)+1
                     i4 = nelm(kb+1)
                     do kk = i3,i4
                        if(nelm(kk).eq.i) then
                           iw = istrw(kk-neqp1)
                           go to 100
                        endif
                     enddo
                  else if(kb.gt.i) then
                     iw = istrw(jj-neqp1)
                  else
                     go to 200
                  endif
 100              cord1j = cord(kb,1)
                  cord2j = cord(kb,2)
                  cord3j = 0.0
                  if(icnl.eq.0) then
                     cord3j = cord(kb,3)
                  endif
                  dis = sqrt((cord1-cord1j)**2 + (cord2-cord2j)**2 +
     &                 (cord3-cord3j)**2)
                  disz2 = cord(kb,igrav)-cord(i,igrav)
                  cosz = abs(disz2)/dis
                  if(disz2.ge.0.0) then
                     sx2c=abs(sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz))
                     areat = max(sx2c*dis*cosz,areat)
                  endif
 200              continue
               enddo
               wellim(i)=areat*area_mult
            else if (ka(i).le.-11.and.ka(i).ge.-13) then
c     constant head or pressure, physically based impedance
               areat = 0.0
               area_mult = wellim(i)
               idir = abs(ka(i))-10
               if(idir.eq.1) then
                  perm = pnx(i)
               else if(idir.eq.2) then
                  perm = pny(i)
               else
                  perm = pnz(i)
               endif
               cord1 = cord(i,1)
               cord2 = cord(i,2)
               cord3 = 0.0
               if(icnl.eq.0) then
                  cord3 = cord(i,3)
               endif
               i1 = nelm(i)+1
               i2 = nelm(i+1)
               do jj = i1,i2
                  kb = nelm(jj)
                  if(kb.lt.i) then
                     i3 = nelmdg(kb)+1
                     i4 = nelm(kb+1)
                     do kk = i3,i4
                        if(nelm(kk).eq.i) then
                           iw = istrw(kk-neqp1)
                           go to 110
                        endif
                     enddo
                  else if(kb.gt.i) then
                     iw = istrw(jj-neqp1)
                  else
                     go to 210
                  endif
 110              cord1j = cord(kb,1)
                  cord2j = cord(kb,2)
                  cord3j = 0.0
                  if(icnl.eq.0) then
                     cord3j = cord(kb,3)
                  endif
                  dis = sqrt((cord1-cord1j)**2 + (cord2-cord2j)**2 +
     &                 (cord3-cord3j)**2)
                  disz2 = cord(kb,idir)-cord(i,idir)
                  cosz = abs(disz2)/dis
                  if(disz2.ge.0.0) then
                     sx2c=abs(sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz))
                     areat = max(sx2c*cosz,areat)
                  endif
 210              continue
               enddo
               dil_dum = dil(i)
               if(irdof.ne.13) then
                  if(rlf(i).lt.1.0) dil_dum =
     &                 dil_dum/max(rlf(i),rlp_min)
               endif
               wellim(i)=areat*area_mult*perm*dil_dum
            endif
         end do
      endif

      end

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM


text:
! :::::::::::::::::::::::::::: FILPATCH :::::::::::::::::::::::::;
!
!  fill the portion of valbig from rows  nrowst
!                             and  cols  ncolst
!  the patch can also be described by the corners (xlp,ybp) by (xrp,ytp).
!  vals are needed at time t, and level level,
!
!  first fill with  values obtainable from the level level
!  grids. if any left unfilled, then enlarge remaining rectangle of
!  unfilled values by 1 (for later linear interp), and recusively
!  obtain the remaining values from  coarser levels.
!
! :::::::::::::::::::::::::::::::::::::::;:::::::::::::::::::::::;
recursive subroutine filrecur(level,nvar,valbig,aux,naux,t,mx,my, &
                              nrowst,ncolst,ilo,ihi,jlo,jhi,patchOnly,msrc,  &
                              do_aux_copy)

    use amr_module, only: nghost, xlower, ylower, xupper, yupper, outunit
    use amr_module, only: xperdom, yperdom, spheredom, hxposs, hyposs
    use amr_module, only: intratx, intraty, iregsz, jregsz
    use amr_module, only: NEEDS_TO_BE_SET

    use geoclaw_module, only: sea_level, dry_tolerance
    use topo_module, only: topo_finalized

    implicit none

    ! Input
    integer, intent(in) :: level, nvar, naux, mx, my, nrowst, ncolst
    integer, intent(in) :: ilo,ihi,jlo,jhi,msrc
    real(kind=8), intent(in) :: t
    logical  :: patchOnly, do_aux_copy, yes_do_aux_copy

    ! Output
    real(kind=8), intent(in out) :: valbig(nvar,mx,my)
    real(kind=8), intent(in out) :: aux(naux,mx,my)

    ! Local storage
    integer  :: iplo, iphi, jplo, jphi

    ! Flagging of set cells
    logical :: set
    integer :: i, i_coarse, j_coarse, i_fine, j_fine, n, k
    integer :: mx_coarse, my_coarse, mx_patch, my_patch
    integer :: unset_indices(4), coarse_indices(4)
    integer :: refinement_ratio_x, refinement_ratio_y
    real(kind=8) :: dx_fine, dy_fine, dx_coarse, dy_coarse
    real(kind=8) :: xlow_coarse,ylow_coarse, xlow_fine, ylow_fine, xhi_fine,yhi_fine
    real(kind=8) :: h, b, eta_fine, eta1, eta2, up_slope, down_slope
    real(kind=8) :: hv_fine, v_fine, v_new, divide_mass
    real(kind=8) :: h_fine_average, h_fine, h_count, h_coarse
    real(kind=8)::  xcent_fine,xcent_coarse,ycent_fine,ycent_coarse,ratio_x,ratio_y
    integer(kind=1) :: flaguse(ihi-ilo+1, jhi-jlo+1)

    real(kind=8) :: eta1old, eta2old

    ! Scratch arrays for interpolation
    logical :: fine_flag(nvar, ihi-ilo+2,jhi-jlo + 2)

    logical :: reloop

    ! these are dimensioned at fine size since coarse grid size cant be larger (incl. the +3 that is )
    real(kind=8) ::  fine_mass(ihi-ilo + 3, jhi-jlo + 3)
    real(kind=8) :: eta_coarse(ihi-ilo + 3, jhi-jlo + 3)
    real(kind=8) ::    vel_max(ihi-ilo + 3, jhi-jlo + 3)
    real(kind=8) ::    vel_min(ihi-ilo + 3, jhi-jlo + 3)
    real(kind=8) ::   slope(2, ihi-ilo + 3, jhi-jlo + 3)
    integer ::   fine_cell_count(ihi-ilo+3, jhi-jlo + 3)

    integer :: nghost_patch, lencrse

    ! Stack storage
    !  use stack-based scratch arrays instead of alloc, since dont really
    !  need to save beyond these routines, and to allow dynami_coarse memory resizing
    !  use 1d scratch arrays that are potentially the same size as
    !  current grid, since may not coarsen.
    !  need to make it 1d instead of 2 and do own indexing, since
    !  when pass it in to subroutines they treat it as having di_fineerent
    !  dimensions than the max size need to allocate here
    ! the +2 is to expand on coarse grid to enclose fine
    real(kind=8) :: valcrse((ihi-ilo+3) * (jhi-jlo+3) * nvar)   ! NB this is a 1D array
    real(kind=8) :: auxcrse((ihi-ilo+3) * (jhi-jlo+3) * naux)

    yes_do_aux_copy = .true.

    mx_patch = ihi-ilo + 1 ! nrowp
    my_patch = jhi-jlo + 1

    dx_fine     = hxposs(level)
    dy_fine     = hyposs(level)

    ! Coordinates of edges of patch (xlp,xrp,ybp,ytp)
    xlow_fine = xlower + ilo * dx_fine
    ylow_fine = ylower + jlo * dy_fine

    ! Fill in the patch as much as possible using values at this level
    ! note that if only a patch, msrc = -1, otherwise a real grid and intfil
    ! uses its boundary list
    ! msrc either -1 (for a patch) or the real grid number
    call intfil(valbig,aux,mx,my,t,flaguse,nrowst,ncolst, ilo,  &
                ihi,jlo,jhi,level,nvar,naux,msrc,do_aux_copy)

    ! Trimbd returns set = true if all of the entries are filled (=1.).
    ! set = false, otherwise. If set = true, then no other levels are
    ! are required to interpolate, and we return.
    !
    ! Note that the used array is filled entirely in intfil, i.e. the
    ! marking done there also takes  into account the points filled by
    ! the boundary conditions. bc2amr will be called later, after all 4
    ! boundary pieces filled.
    call trimbd(flaguse,mx_patch,my_patch,set,unset_indices)
    ! il,ir,jb,jt = unset_indices(4)

    ! If set is .true. then all cells have been set and we can skip to setting
    ! the remaining boundary cells.  If it is .false. we need to interpolate
    ! some values from coarser levels, possibly calling this routine
    ! recursively.
    if (.not.set) then

        ! Error check
        if (level == 1) then
            write(outunit,*)" error in filrecur - level 1 not set"
            write(outunit,'("start at row: ",i4," col ",i4)') nrowst,ncolst
            print *," error in filrecur - level 1 not set"
            print *," should not need more recursion "
            print *," to set patch boundaries"
            print '("start at row: ",i4," col ",i4)', nrowst,ncolst
            stop
        endif

        ! We begin by initializing the level level arrays, so that we can use
        ! purely recursive formulation for interpolating.
        dx_coarse  = hxposs(level - 1)
        dy_coarse  = hyposs(level - 1)

        ! Adjust unset_indices to account for the patch
        ! isl, isr, jsb, jst
        unset_indices(1) = unset_indices(1) + ilo - 1
        unset_indices(2) = unset_indices(2) + ilo - 1
        unset_indices(3) = unset_indices(3) + jlo - 1
        unset_indices(4) = unset_indices(4) + jlo - 1

        ! Coarsened geometry
        refinement_ratio_x = intratx(level - 1)
        refinement_ratio_y = intraty(level - 1)

        ! New patch rectangle (after we have partially filled it in) but in the
        ! coarse patches [iplo,iphi,jplo,jphi]

        iplo = (unset_indices(1) - refinement_ratio_x + nghost * refinement_ratio_x) &
                                                / refinement_ratio_x - nghost
        iphi = (unset_indices(2) + refinement_ratio_x) / refinement_ratio_x
        jplo = (unset_indices(3) - refinement_ratio_y + nghost * refinement_ratio_y) &
                                                / refinement_ratio_y - nghost
        jphi = (unset_indices(4) + refinement_ratio_y) / refinement_ratio_y

        xlow_coarse = xlower + iplo * dx_coarse
        ylow_coarse = ylower + jplo * dy_coarse

        ! Coarse grid number of spatial points (nrowc,ncolc)
        mx_coarse   =  iphi - iplo  + 1
        my_coarse   =  jphi - jplo  + 1

        ! Check to make sure we created big enough scratch arrays
        if (mx_coarse > ihi - ilo + 3 .or. &
            my_coarse > jhi - jlo + 3) then

            print *," did not make big enough work space in filrecur "
            print *," need coarse space with mx_coarse,my_coarse ",mx_coarse,my_coarse
            print *," made space for ilo,ihi,jlo,jhi ",ilo,ihi,jlo,jhi
            stop
        endif

        ! Set the aux array values for the coarse grid, this could be done
        ! instead in intfil using possibly already available bathy data from the
        ! grids

        if (naux > 0) then
            nghost_patch = 0
            lencrse = (ihi-ilo+3)*(jhi-jlo+3)*naux ! set 1 component, not all naux
            ! new system checks initialization before setting aux vals
            ! set here and check later if not all set by copying in intfil
            ! after some more testing shoudl move thiese auxcrse initialization
            ! into the branches that need it (topo_finalized dand periodic
            ! but out of the most used filrecur pathway
            do k = 1, lencrse, naux
              auxcrse(k) = NEEDS_TO_BE_SET
            end do

            ! update topography if needed
            !if ((num_dtopo>0).and.(topo_finalized.eqv..false.)) then
            !   if ((minval(topotime)<maxval(tfdtopo)).and.(t>=minval(t0dtopo))) then
            if (.not. topo_finalized) then
                call topo_update(t)
                call setaux(nghost_patch, mx_coarse, my_coarse,       &
                            xlow_coarse, ylow_coarse,                 &
                            dx_coarse,dy_coarse,naux,auxcrse)
                yes_do_aux_copy = .false. !grids may not have latest topo
            endif
        endif

        ! Fill in the edges of the coarse grid
        if ((xperdom .or. (yperdom .or. spheredom)) .and. sticksout(iplo,iphi,jplo,jphi)) then
            call setaux(nghost_patch, mx_coarse, my_coarse,       &
                        xlow_coarse, ylow_coarse,                 &
                        dx_coarse,dy_coarse,naux,auxcrse)
            call prefilrecur(level-1,nvar,valcrse,auxcrse,naux,t, &
                             mx_coarse,my_coarse,1,1,iplo,iphi,jplo,jphi,iplo,iphi,jplo,jphi,.true.)
        else ! when going to coarser patch, no source grid (for now at least) hence -1
            call filrecur(level-1,nvar,valcrse,auxcrse,naux,t,  &
                          mx_coarse,my_coarse,1,1,iplo,iphi,jplo,jphi,.true.,-1,    &
                          yes_do_aux_copy)
            !call setaux(nghost_patch, mx_coarse, my_coarse,       &
            !            xlow_coarse, ylow_coarse,                 &
            !            dx_coarse,dy_coarse,naux,auxcrse)
        endif

        ! loop through coarse cells determining intepolation slopes
        ! these will be saved for fine grid loop
        ! prevents finding the same slope possibly lratiox*lratioy times
        ! all fine gid depths will be found before any momentum
        reloop = .false.
        fine_cell_count = 0
        fine_flag = .false.
        fine_mass = 0.d0
        slope = 0.d0

        ! Calculate surface elevation eta using dry limiting
        do j_coarse = 1, my_coarse
            do i_coarse = 1, mx_coarse
                h = valcrse(ivalc(1,i_coarse,j_coarse))
                b = auxcrse(iauxc(i_coarse,j_coarse))

                if (h < dry_tolerance) then
                    eta_coarse(i_coarse,j_coarse) = sea_level
                else
                    eta_coarse(i_coarse,j_coarse) = h + b
                endif
            enddo
        enddo

        ! Calculate limited gradients of coarse grid eta
        do j_coarse = 2, my_coarse - 1
           do i_coarse = 2, mx_coarse - 1

                ! X-Direction
                down_slope = eta_coarse(i_coarse,j_coarse) - eta_coarse(i_coarse-1,j_coarse)
                up_slope = eta_coarse(i_coarse+1,j_coarse) - eta_coarse(i_coarse,j_coarse)
                if (up_slope * down_slope > 0.d0) then
                    slope(1,i_coarse,j_coarse) = min(abs(up_slope), abs(down_slope)) &
                        * sign(1.d0,eta_coarse(i_coarse+1,j_coarse) - eta_coarse(i_coarse-1,j_coarse))
                endif

                ! Y-Direction
                down_slope = eta_coarse(i_coarse,j_coarse) - eta_coarse(i_coarse,j_coarse-1)
                up_slope = eta_coarse(i_coarse,j_coarse+1) - eta_coarse(i_coarse,j_coarse)
                if (up_slope * down_slope > 0.d0) then
                    slope(2,i_coarse,j_coarse) = min(abs(up_slope), abs(down_slope)) &
                        * sign(1.d0,eta_coarse(i_coarse+1,j_coarse) - eta_coarse(i_coarse-1,j_coarse))
                endif
            enddo
        enddo

        ratio_y = real(refinement_ratio_y,kind=8)  ! needs to be real for "floor" call below
        ratio_x = real(refinement_ratio_x,kind=8)
        ! Loop through patch to be filled, includes multiple coarse cells
         do j_fine = 1, my_patch
            j_coarse     = floor((j_fine + jlo - 1) / ratio_y) - jplo + 1
            ycent_coarse = ylow_coarse + (j_coarse-.5d0)*dy_coarse
            ycent_fine   = ylower + (j_fine-1+jlo + .5d0)*dy_fine
            eta2         = (ycent_fine-ycent_coarse)/dy_coarse
            if (abs(eta2) .gt. .5d0) then
                write(*,*)" filpatch y indexing error: eta2 = ",eta2
            endif
            !eta2old = (-0.5d0 + real(mod(j_fine - 1, refinement_ratio_y),kind=8)) &
            !                        / real(refinement_ratio_y,kind=8)
            do i_fine = 1, mx_patch
                i_coarse     = floor((i_fine+ilo-1) / ratio_x) - iplo + 1
                xcent_coarse = xlow_coarse + (i_coarse-.5d0)*dx_coarse
                xcent_fine   =  xlower + (i_fine-1+ilo + .5d0)*dx_fine
                eta1         = (xcent_fine-xcent_coarse)/dx_coarse
                if (abs(eta1) .gt. .5d0) then
                   write(*,*)" filpatch x indexing error: eta1 = ",eta1
                endif
                !eta1old = (-0.5d0 + real(mod(i_fine - 1, refinement_ratio_x),kind=8)) &
                !                / real(refinement_ratio_x,kind=8)

                if (flaguse(i_fine,j_fine) == 0) then
                    ! Interpolate from coarse cells to fine grid for surface
                    fine_cell_count(i_coarse,j_coarse) = fine_cell_count(i_coarse,j_coarse) + 1
                    eta_fine = eta_coarse(i_coarse,j_coarse) + eta1 * slope(1,i_coarse,j_coarse) &
                                                             + eta2 * slope(2,i_coarse,j_coarse)
                    h_fine = max(eta_fine - aux(1,i_fine + nrowst - 1, j_fine + ncolst - 1), 0.d0)
                    valbig(1,i_fine+nrowst-1, j_fine+ncolst-1) = h_fine
                    fine_mass(i_coarse,j_coarse) = fine_mass(i_coarse,j_coarse) + h_fine

                    ! Flag the corresponding coarse cell as needing relimiting
                    ! if one of the fine cells ends up being dry
                    if (h_fine < dry_tolerance) then
                        fine_flag(1,i_coarse,j_coarse) = .true.
                        reloop = .true.
                    endif
                endif
            enddo
        enddo

        ! Momentum Interpolation
        do n = 2, nvar
          do j_coarse = 2, my_coarse - 1
            do i_coarse = 2, mx_coarse - 1

                    ! Determine slopes for interpolation
                    down_slope = (valcrse(ivalc(n,i_coarse,j_coarse)) - valcrse(ivalc(n,i_coarse-1,j_coarse)))
                    up_slope   = (valcrse(ivalc(n,i_coarse+1,j_coarse)) - valcrse(ivalc(n,i_coarse,j_coarse)))
                    if (up_slope * down_slope > 0.d0) then
                        slope(1,i_coarse,j_coarse) = min(abs(up_slope), abs(down_slope)) *    &
                                          sign(1.d0, valcrse(ivalc(n,i_coarse+1,j_coarse))    &
                                           - valcrse(ivalc(n,i_coarse-1,j_coarse)))
                    endif

                    down_slope = (valcrse(ivalc(n,i_coarse,j_coarse)) - valcrse(ivalc(n,i_coarse,j_coarse-1)))
                    up_slope   = (valcrse(ivalc(n,i_coarse,j_coarse+1)) - valcrse(ivalc(n,i_coarse,j_coarse)))
                    if (up_slope * down_slope > 0.d0) then
                        slope(2,i_coarse,j_coarse) = min(abs(up_slope), abs(down_slope))       &
                                         * sign(1.d0, valcrse(ivalc(n,i_coarse,j_coarse+1))    &
                                          - valcrse(ivalc(n,i_coarse,j_coarse-1)))
                    endif

                    ! Set initial values for max/min of current field
                    if (valcrse(ivalc(1,i_coarse,j_coarse)) > dry_tolerance) then
                        vel_max(i_coarse,j_coarse) = valcrse(ivalc(n,i_coarse,j_coarse)) /    &
                                                     valcrse(ivalc(1,i_coarse,j_coarse))
                        vel_min(i_coarse,j_coarse) = valcrse(ivalc(n,i_coarse,j_coarse)) /    &
                                                     valcrse(ivalc(1,i_coarse,j_coarse))
                    else
                        vel_min(i_coarse,j_coarse) = 0.d0
                        vel_max(i_coarse,j_coarse) = 0.d0
                    endif

                    ! Look for bounds on velocity around each cell
                    ! Necessary since we are interpolating momentum linearly
                    ! but not interpolating depth linearly
                    do i =-1,1,2
                        if (valcrse(ivalc(1,i_coarse + i,j_coarse)) > dry_tolerance) then
                            vel_max(i_coarse,j_coarse) =  max(vel_max(i_coarse,j_coarse),      &
                                                valcrse(ivalc(n,i_coarse + i,j_coarse)) /      &
                                                valcrse(ivalc(1,i_coarse + i,j_coarse)))
                            vel_min(i_coarse,j_coarse) = min(vel_min(i_coarse,j_coarse),       &
                                                valcrse(ivalc(n,i_coarse + i,j_coarse)) /      &
                                                valcrse(ivalc(1,i_coarse + i,j_coarse)))
                        endif

                        if (valcrse(ivalc(1,i_coarse,j_coarse + i)) > dry_tolerance) then
                            vel_max(i_coarse,j_coarse) = max(vel_max(i_coarse,j_coarse),       &
                                                  valcrse(ivalc(n,i_coarse,j_coarse + i)) /    &
                                                  valcrse(ivalc(1,i_coarse,j_coarse + i)))
                            vel_min(i_coarse,j_coarse) = min(vel_min(i_coarse,j_coarse),       &
                                                  valcrse(ivalc(n,i_coarse,j_coarse + i)) /    &
                                                  valcrse(ivalc(1,i_coarse,j_coarse + i)))

                        endif
                    enddo
                enddo
            enddo

            ! Determine momentum in fine cells
            do j_fine = 1, my_patch
                j_coarse     = floor((j_fine + jlo - 1) / ratio_y) - jplo + 1
                ycent_coarse = ylow_coarse + (j_coarse-.5d0)*dy_coarse
                ycent_fine   =  ylower + (j_fine-1+jlo + .5d0)*dy_fine
                eta2         = (ycent_fine-ycent_coarse)/dy_coarse

                do i_fine = 1, mx_patch
                    i_coarse     = floor((i_fine+ilo-1) / ratio_x) - iplo + 1
                    xcent_coarse = xlow_coarse + (i_coarse-.5d0)*dx_coarse
                    xcent_fine   =  xlower + (i_fine-1+ilo + .5d0)*dx_fine
                    eta1         = (xcent_fine-xcent_coarse)/dx_coarse

                    if (flaguse(i_fine,j_fine) == 0) then
                        ! Cell not already set

                        if (.not.(fine_flag(1,i_coarse,j_coarse))) then
                            ! This cell has no coarse cells that are dry
                            hv_fine = valcrse(ivalc(n,i_coarse,j_coarse))         &
                                            + eta1 * slope(1,i_coarse,j_coarse)   &
                                            + eta2 * slope(2,i_coarse,j_coarse)
                            v_fine = hv_fine  / valbig(1,i_fine+nrowst-1, j_fine+ncolst-1)
                            if (v_fine<vel_min(i_coarse,j_coarse) .or.  v_fine>vel_max(i_coarse,j_coarse)) then
                                fine_flag(n,i_coarse,j_coarse) = .true.
                                reloop = .true.
                            else
                                valbig(n,i_fine+nrowst-1,j_fine+ncolst-1) = hv_fine
                            endif
                        endif
                    endif
                enddo
            enddo

            ! Reset momentum to conserve momentum in the cases where we may have
            ! gained momentum or if velocity bounds were violated
            if (reloop) then

                do j_fine  = 1, my_patch
                  j_coarse     = floor((j_fine + jlo - 1) / ratio_y) - jplo + 1
                  ycent_coarse = ylow_coarse + (j_coarse-.5d0)*dy_coarse
                  ycent_fine   =  ylower + (j_fine-1+jlo + .5d0)*dy_fine
                  eta2         = (ycent_fine-ycent_coarse)/dy_coarse

                    do i_fine = 1, mx_patch
                       i_coarse     = floor((i_fine+ilo-1) / ratio_x) - iplo + 1
                       xcent_coarse = xlow_coarse + (i_coarse-.5d0)*dx_coarse
                       xcent_fine   =  xlower + (i_fine-1+ilo + .5d0)*dx_fine
                       eta1         = (xcent_fine-xcent_coarse)/dx_coarse

                        if (flaguse(i_fine,j_fine) == 0) then
                            if (fine_flag(1,i_coarse,j_coarse) .or. fine_flag(n,i_coarse,j_coarse)) then
                                if (fine_mass(i_coarse,j_coarse) > dry_tolerance) then
                                    h_coarse = valcrse(ivalc(1,i_coarse,j_coarse))
                                    h_count = real(fine_cell_count(i_coarse,j_coarse),kind=8)
                                    h_fine_average = fine_mass(i_coarse,j_coarse) / h_count
                                    divide_mass = max(h_coarse, h_fine_average)
                                    h_fine = valbig(1, i_fine + nrowst - 1, j_fine + ncolst - 1)
                                    v_new = valcrse(ivalc(n,i_coarse,j_coarse)) / (divide_mass)

                                    valbig(n,i_fine+nrowst-1,j_fine+ncolst-1) = &
                                        v_new * valbig(1,i_fine+nrowst-1,j_fine+ncolst-1)
                                else
                                    valbig(n,i_fine+nrowst-1,j_fine+ncolst-1) = 0.d0
                                endif
                            endif
                        endif
                    enddo
                enddo
            endif ! end if reloop
        enddo  ! end loop over nvar
    endif   ! end if patch not set

    ! set bcs, whether or not recursive calls needed. set any part of patch that stuck out
    xhi_fine = xlower + (ihi + 1) * dx_fine
    yhi_fine = ylower + (jhi + 1) * dy_fine
    if (patchOnly) then
       call bc2amr(valbig,aux,mx,my,nvar,naux,dx_fine,dy_fine,level,t,   &
                   xlow_fine,xhi_fine,ylow_fine,yhi_fine)
    endif

contains

    integer pure function ivalc(n,i,j)
        implicit none
        integer, intent(in) :: n,i,j
        ivalc = n + nvar*(i-1) + nvar*mx_coarse*(j-1)
    end function ivalc

    ! Index into first component of aux = topo:
    integer pure function iauxc(i,j)
        implicit none
        integer, intent(in) :: i,j
        iauxc = 1 + naux*(i-1) + naux*mx_coarse*(j-1)
    end function iauxc

    ! logical for checking if this patch sticks outside of the domain
    logical pure function sticksout(iplo,iphi,jplo,jphi)
        implicit none
        integer, intent(in) :: iplo,iphi,jplo,jphi
        sticksout = (iplo < 0 .or. jplo < 0 .or. &
                     iphi >= iregsz(level - 1) .or. jphi >= jregsz(level - 1))
    end function sticksout

end subroutine filrecur

max_forks_repo_name: mjberger/geoclaw


text:
module Mod_nsc_pr_ComputeVariables
   use typre
   use Mod_nsc_pr_BaseElmope
   implicit none
   private
   public SetPointersVariables

   !External Procedures
   procedure() :: NULLSUB

   integer(ip), allocatable :: kfl_IsSet

contains

   subroutine SetPointersVariables(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

            !Non-linear subscales
            if (a%kfl_nolsg == 1) then
               call ConcatenateProcedures(ProcPointer_nsc_pr_ComputeVariables,ComputeNonlinearVariables)
            endif

            call ConcatenateProcedures(ProcPointer_nsc_pr_ComputeVariables,ComputeAuxiliaryVariables)

            !State law
            if (a%lawde /= 0) then
               if (a%lawde == 1) then
                  call ConcatenateProcedures(ProcPointer_nsc_pr_ComputeVariables,ComputeIdealAuxVariables)
               else if (a%lawde /= 1) then
                  call runend('Nsc_elmope: Non-ideal state law not ready')
               endif
            endif

         endif

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

      end select
   end subroutine

   !-----------------------------------------------------------------------
   !Actual Computations

   subroutine ComputeNonlinearVariables
      implicit none

      gpadp = gpadp       + a%cosgs(ielem)%a(1,e%igaus)
      gpadv(:) = gpadv(:) + a%mosgs(ielem)%a(:,1,e%igaus)
      gpadt = gpadt       + a%ensgs(ielem)%a(1,e%igaus)

   end subroutine

   subroutine ComputeAuxiliaryVariables
      implicit none

      !Advection velocity norm
      call vecnor(gpadv,e%ndime,gpvno,2)

   end subroutine

   ! Ideal Gas Law auxiliary variables
   subroutine ComputeIdealAuxVariables
      implicit none

      gpden = gpadp/((accph-accvh)*gpadt)
      aux = gpden*(accvh*gpadt+gpvno*gpvno/2.0_rp)+gpadp
      acalpha = 1.0_rp/gpadt
      acbeta = 1.0_rp/gpadp

   end subroutine
end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
SUBROUTINE traspdist( a, b, idir )

   use parameter_mod
   use dom_distr_mod
   use parallel_mod

   IMPLICIT NONE
   include 'mpif.h'

   REAL(dp) :: a( nxl, ny, nz ), b( nx, nyt, nz )
   INTEGER  :: idir

   INTEGER  :: ip, srsize, ib
   INTEGER  :: ix, iy, iz, ierr

   REAL(dp), ALLOCATABLE :: rbuf( : )
   REAL(dp), ALLOCATABLE :: sbuf( : )

   ALLOCATE( rbuf( nxlmax * nytmax * nz * nprow) )
   ALLOCATE( sbuf( nxlmax * nytmax * nz * nprow) )

srsize = nxlmax*nytmax*nz

!  do iy = 1, ny
!    do ix = 1, nxl
!      a(ix,iy,:) = (mpime + 1) * iy
!    enddo
!  enddo

!  do iy = 1, ny
!    do ix = 1, nxl
!      write(*,*) a(ix,iy,1)
!    enddo
!  enddo
!  write(*,*) 'puppa1'

   IF( idir > 0 ) THEN

do ip = 1, nprow
 ib = 0
  do iz = 1, nz
    do iy = 1, nytp(ip)
      do ix = 1, nxl
       ib = ib + 1
        sbuf(ib+(ip-1)*srsize) = a(ix,iy + iytgp(ip) - 1,iz)
      enddo
    enddo
  enddo
enddo

      CALL MPI_ALLTOALL( sbuf, srsize, MPI_DOUBLE_PRECISION, &
             rbuf, srsize, MPI_DOUBLE_PRECISION, &
             MPI_COMM_WORLD, ierr )

     do ip = 1, nprow
      ib = 0
       do iz = 1, nz
         do iy = 1, nyt
           do ix = 1, nxlp(ip)
            ib = ib + 1
             b(ix + ixlgp(ip) - 1, iy, iz) = rbuf(ib + (ip-1)*srsize)
           enddo
         enddo
       enddo
     enddo

!do iy = 1, nyt
!  do ix = 1, nx
!    write(*,*) b(ix,iy,1)
!  enddo
!enddo
!write(*,*) 'puppa2'

   ELSE

     do ip = 1, nprow
      ib = 0
       do iz = 1, nz
         do iy = 1, nyt
           do ix = 1, nxlp(ip)
            ib = ib + 1
             rbuf(ib + (ip-1)*srsize) = b(ix + ixlgp(ip) - 1, iy, iz)
           enddo
         enddo
       enddo
     enddo

      CALL MPI_ALLTOALL( rbuf, srsize, MPI_DOUBLE_PRECISION, &
             sbuf, srsize, MPI_DOUBLE_PRECISION, &
             MPI_COMM_WORLD, ierr )

do ip = 1, nprow
 ib = 0
  do iz = 1, nz
    do iy = 1, nytp(ip)
      do ix = 1, nxl
       ib = ib + 1
        a(ix,iy + iytgp(ip) - 1,iz) = sbuf(ib+(ip-1)*srsize)
      enddo
    enddo
  enddo
enddo

!do iy = 1, ny
!  do ix = 1, nxl
!    write(*,*) a(ix,iy,1)
!  enddo
!enddo
!write(*,*) 'puppa3'
!call syncronize
!stop

   END IF

   DEALLOCATE( rbuf )
   DEALLOCATE( sbuf )

   RETURN
END SUBROUTINE

max_stars_repo_name: sscerr/eTF

max_issues_repo_name: sscerr/eTF

max_forks_repo_name: sscerr/eTF


text:
!	Basic input specifications.
!	fileformat is the Fortran format for reading the data.
!	filename is the file name.
!	nexternal is the number of external variables.
!	nitems is the number of items.
!	nobs is the number of observations,nitems is the number of items.
!	nobsstart is the initial sample size for starting calculations.
!	npred is the number of predictors.
!	complx is stratify.or.usepsu.or.weight.
!	distract is .true. if distractors are read.
!	recode is used for item recoding.
!	recodedist indicates if distractor recodes are present.
!	stratify is the indicator of whether sampling is stratified.
!	If true, useid causes reading of an examinee identification code.
!	usepsu is the indicator of whether primary sampling units are involved.
!	weight indicates that weighting is used for observations.
subroutine getdataspec(fileformat,filename,nexternal,nitems,nobs,nobsstart,npred,&
	complx,distract,recode,recodedist,stratify,useid,usepsu,weight)
implicit none

character(len=256),intent(out)::fileformat
character(len=256),intent(out)::filename
integer,intent(out)::nexternal,nitems,nobs,nobsstart,npred
logical,intent(out)::complx,distract,recode,recodedist,stratify,useid,usepsu,weight

!	idcheck is a character variable used in the input testing.
character(len=32),allocatable::idcheck(:)

!	At least minobs observations are needed.
integer,parameter::minobs=2
!	counter counts records.
!	io indicates a reading issue.
!	nfloat is the number of floating-point numbers to be read.
!	nid is the number of character variables to read.
!	nitems1 is nitems if distractors are not analyzed and 2 times nitems of distractors are analyzed.
!	nsamp is the number of variables related to sampling.
integer::counter,io,nfloat,nid,nitems1,nsamp
!	csamp is the specification for a complex sample.
!	resp is a response.
integer,allocatable::csamp(:),resp(:)
!	x is for floating point portions of a record.
real(kind=8),allocatable::x(:)
namelist/dataspec/fileformat,filename,nexternal,nitems,nobs,nobsstart,npred,&
	complx,distract,recode,recodedist,stratify,useid,usepsu,weight

!	Default values
fileformat="*"
filename="data.txt"
nexternal=0
nitems=0
nobs=0
nobsstart=1000
npred=1

complx=.false.
distract=.false.
recode=.false.
recodedist=.false.
stratify=.false.
useid=.false.
usepsu=.false.
weight=.false.

nid=0
nsamp=0

read(*,nml=dataspec,iostat=io)
if(io/=0)stop "Data specification information not valid"
if(nexternal<0) nexternal=0
if(nitems<1) stop "Number of items not positive"
if(npred<1) npred=1
if(.not.distract)recodedist=.false.
complx=stratify.or.usepsu.or.(weight.and.complx)
open(8,file=filename,iostat=io)
if(io/=0) stop "Data file cannot be opened."
if(stratify)nsamp=nsamp+1
if(usepsu)nsamp=nsamp+1
if(weight)then
	nfloat=npred+nexternal
else
	nfloat=npred+nexternal-1
end if
if(useid)nid=1
!	Count up number of observations.
counter=0
if(nobs<=0) nobs=huge(nobs)
nitems1=nitems
if(distract)nitems1=nitems1+nitems1
allocate(idcheck(nid),resp(nitems1),x(nfloat),csamp(nsamp))
do while(counter<nobs)

	if(fileformat/="*")then
		read(8,fmt=fileformat,iostat=io) idcheck,resp,x,csamp
	else
		read(8,*,iostat=io) idcheck,resp,x,csamp
	end if
	if(io>0) stop "Read error encountered"
	if(io<0) exit
	counter=counter+1
end do

nobs=counter
if(nobs<minobs) stop "Insufficient data for analysis."
!	Initial sample cannot be larger than final sample.
if(nobsstart<=0) nobsstart=1000
nobsstart=min(nobs,nobsstart)
rewind(8)
return
end subroutine getdataspec

max_stars_repo_name: EducationalTestingService/MIRT

max_issues_repo_name: EducationalTestingService/MIRT

max_forks_repo_name: EducationalTestingService/MIRT


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> A module for computing estimates of the bounds of the spectrum of a matrix.
MODULE EigenBoundsModule
  USE DataTypesModule, ONLY : NTREAL, MPINTREAL
  USE LoggingModule, ONLY : EnterSubLog, ExitSubLog, WriteElement, &
       & WriteListElement, WriteHeader
  USE PMatrixMemoryPoolModule, ONLY : MatrixMemoryPool_p, &
       & DestructMatrixMemoryPool
  USE PSMatrixAlgebraModule, ONLY : MatrixMultiply, MatrixNorm, DotMatrix, &
       & IncrementMatrix, ScaleMatrix
  USE PSMatrixModule, ONLY : Matrix_ps, ConstructEmptyMatrix, CopyMatrix, &
       & DestructMatrix, GetMatrixTripletList, FillMatrixFromTripletList
  USE SolverParametersModule, ONLY : SolverParameters_t, PrintParameters
  USE TripletListModule, ONLY : TripletList_r, TripletList_c, &
       & AppendToTripletList, DestructTripletList
  USE TripletModule, ONLY : Triplet_r
  USE NTMPIModule
  IMPLICIT NONE
  PRIVATE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  PUBLIC :: GershgorinBounds
  PUBLIC :: PowerBounds
CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Compute a bounds on the minimum and maximum eigenvalue of a matrix.
  !> Uses the Gershgorin theorem.
  SUBROUTINE GershgorinBounds(this,min_value,max_value)
    !> The matrix to compute the min/max of.
    TYPE(Matrix_ps), INTENT(IN) :: this
    !> A lower bound on the eigenspectrum.
    REAL(NTREAL), INTENT(OUT) :: min_value
    !> An uppder bound on the eigenspectrum.
    REAL(NTREAL), INTENT(OUT) :: max_value
    !! Local Data
    TYPE(TripletList_r) :: triplet_list_r
    TYPE(TripletList_c) :: triplet_list_c
    !! Local Data
    REAL(NTREAL), DIMENSION(:), ALLOCATABLE :: per_column_min
    REAL(NTREAL), DIMENSION(:), ALLOCATABLE :: per_column_max
    !! Counters/Temporary
    INTEGER :: counter
    INTEGER :: local_column
    INTEGER :: ierr

    IF (this%is_complex) THEN
  !! Allocate Space For Result
  ALLOCATE(per_column_min(this%local_columns))
  ALLOCATE(per_column_max(this%local_columns))

  !! Compute The Local Contribution
  per_column_min = 0
  per_column_max = 0
  CALL GetMatrixTripletList(this, triplet_list_c)
  DO counter = 1, triplet_list_c%CurrentSize
     local_column = triplet_list_c%DATA(counter)%index_column - &
          & this%start_column + 1
     IF (triplet_list_c%DATA(counter)%index_row .EQ. &
          & triplet_list_c%DATA(counter)%index_column) THEN
        per_column_min(local_column) = per_column_min(local_column) + &
             & REAL(triplet_list_c%DATA(counter)%point_value,KIND=NTREAL)
        per_column_max(local_column) = per_column_max(local_column) + &
             & REAL(triplet_list_c%DATA(counter)%point_value,KIND=NTREAL)
     ELSE
        per_column_min(local_column) = per_column_min(local_column) - &
             & ABS(triplet_list_c%DATA(counter)%point_value)
        per_column_max(local_column) = per_column_max(local_column) + &
             & ABS(triplet_list_c%DATA(counter)%point_value)
     END IF
  END DO

  !! Sum Along Columns
  CALL MPI_Allreduce(MPI_IN_PLACE,per_column_min,SIZE(per_column_min), &
       & MPINTREAL,MPI_SUM,this%process_grid%column_comm,ierr)
  CALL MPI_Allreduce(MPI_IN_PLACE,per_column_max,SIZE(per_column_max), &
       & MPINTREAL,MPI_SUM,this%process_grid%column_comm,ierr)

  min_value = MINVAL(per_column_min)
  max_value = MAXVAL(per_column_max)

  CALL MPI_Allreduce(MPI_IN_PLACE,min_value,1,MPINTREAL,MPI_MIN, &
       & this%process_grid%row_comm, ierr)
  CALL MPI_Allreduce(MPI_IN_PLACE,max_value,1,MPINTREAL,MPI_MAX, &
       & this%process_grid%row_comm, ierr)

  CALL DestructTripletList(triplet_list_c)
  DEALLOCATE(per_column_min)
  DEALLOCATE(per_column_max)
    ELSE
  !! Allocate Space For Result
  ALLOCATE(per_column_min(this%local_columns))
  ALLOCATE(per_column_max(this%local_columns))

  !! Compute The Local Contribution
  per_column_min = 0
  per_column_max = 0
  CALL GetMatrixTripletList(this, triplet_list_r)
  DO counter = 1, triplet_list_r%CurrentSize
     local_column = triplet_list_r%DATA(counter)%index_column - &
          & this%start_column + 1
     IF (triplet_list_r%DATA(counter)%index_row .EQ. &
          & triplet_list_r%DATA(counter)%index_column) THEN
        per_column_min(local_column) = per_column_min(local_column) + &
             & REAL(triplet_list_r%DATA(counter)%point_value,KIND=NTREAL)
        per_column_max(local_column) = per_column_max(local_column) + &
             & REAL(triplet_list_r%DATA(counter)%point_value,KIND=NTREAL)
     ELSE
        per_column_min(local_column) = per_column_min(local_column) - &
             & ABS(triplet_list_r%DATA(counter)%point_value)
        per_column_max(local_column) = per_column_max(local_column) + &
             & ABS(triplet_list_r%DATA(counter)%point_value)
     END IF
  END DO

  !! Sum Along Columns
  CALL MPI_Allreduce(MPI_IN_PLACE,per_column_min,SIZE(per_column_min), &
       & MPINTREAL,MPI_SUM,this%process_grid%column_comm,ierr)
  CALL MPI_Allreduce(MPI_IN_PLACE,per_column_max,SIZE(per_column_max), &
       & MPINTREAL,MPI_SUM,this%process_grid%column_comm,ierr)

  min_value = MINVAL(per_column_min)
  max_value = MAXVAL(per_column_max)

  CALL MPI_Allreduce(MPI_IN_PLACE,min_value,1,MPINTREAL,MPI_MIN, &
       & this%process_grid%row_comm, ierr)
  CALL MPI_Allreduce(MPI_IN_PLACE,max_value,1,MPINTREAL,MPI_MAX, &
       & this%process_grid%row_comm, ierr)

  CALL DestructTripletList(triplet_list_r)
  DEALLOCATE(per_column_min)
  DEALLOCATE(per_column_max)
    END IF
  END SUBROUTINE GershgorinBounds
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Compute a bounds on the maximum eigenvalue of a matrix.
  !> Uses The Power Method.
  SUBROUTINE PowerBounds(this,max_value,solver_parameters_in)
    !> The matrix to compute the min/max of.
    TYPE(Matrix_ps), INTENT(IN) :: this
    !> An upper bound on the eigenspectrum.
    REAL(NTREAL), INTENT(OUT) :: max_value
    !> The parameters for this calculation.
    TYPE(SolverParameters_t), INTENT(IN), OPTIONAL :: solver_parameters_in
    !! Handling Optional Parameters
    TYPE(SolverParameters_t) :: solver_parameters
    !! Local Data
    TYPE(Matrix_ps) :: vector, vector2, TempMat
    REAL(NTREAL) :: scale_value
    REAL(NTREAL) :: norm_value
    TYPE(TripletList_r) :: temp_list
    TYPE(Triplet_r) :: temp_triplet
    INTEGER :: outer_counter
    TYPE(MatrixMemoryPool_p) :: pool

    !! Optional Parameters
    IF (PRESENT(solver_parameters_in)) THEN
       solver_parameters = solver_parameters_in
    ELSE
       solver_parameters = SolverParameters_t()
       solver_parameters%max_iterations = 10
    END IF

    IF (solver_parameters%be_verbose) THEN
       CALL WriteHeader("Power Bounds Solver")
       CALL EnterSubLog
       CALL PrintParameters(solver_parameters)
    END IF

    !! Diagonal matrices serve as vectors.
    CALL ConstructEmptyMatrix(vector, this)
    CALL ConstructEmptyMatrix(vector2, this)

    !! Guess Vector
    temp_list = TripletList_r()
    IF (this%process_grid%global_rank .EQ. 0) THEN
       temp_triplet%index_row = 1
       temp_triplet%index_column = 1
       temp_triplet%point_value = 1.0_NTREAL
       CALL AppendToTripletList(temp_list,temp_triplet)
    END IF
    CALL FillMatrixFromTripletList(vector,temp_list)

    !! Iterate
    IF (solver_parameters%be_verbose) THEN
       CALL WriteHeader("Iterations")
       CALL EnterSubLog
    END IF
    outer_counter = 1
    norm_value = solver_parameters%converge_diff + 1.0_NTREAL
    DO outer_counter = 1,solver_parameters%max_iterations
       IF (solver_parameters%be_verbose .AND. outer_counter .GT. 1) THEN
          CALL WriteListElement(key="Round", VALUE=outer_counter-1)
          CALL EnterSubLog
          CALL WriteElement(key="Convergence", VALUE=norm_value)
          CALL ExitSubLog
       END IF

       !! x = Ax
       CALL MatrixMultiply(this,vector,vector2, &
            & threshold_in=solver_parameters%threshold, memory_pool_in=pool)
       !! x = x/||x||
       scale_value = 1.0/MatrixNorm(vector2)
       CALL ScaleMatrix(vector2,scale_value)

       !! Check if Converged
       CALL IncrementMatrix(vector2,vector,-1.0_NTREAL)
       norm_value = MatrixNorm(vector)

       CALL CopyMatrix(vector2,vector)

       IF (norm_value .LE. solver_parameters%converge_diff) THEN
          EXIT
       END IF
    END DO
    IF (solver_parameters%be_verbose) THEN
       CALL ExitSubLog
       CALL WriteElement(key="Total_Iterations",VALUE=outer_counter-1)
    END IF

    !! Compute The Largest Eigenvalue
    CALL DotMatrix(vector, vector, scale_value)
    CALL MatrixMultiply(this,vector,vector2, &
         & threshold_in=solver_parameters%threshold, memory_pool_in=pool)
    CALL DotMatrix(vector, vector2, max_value)
    max_value = max_value / scale_value

    IF (solver_parameters%be_verbose) THEN
       CALL WriteElement(key="Max_Eigen_Value",VALUE=max_value)
       CALL ExitSubLog
    END IF

    !! Cleanup
    CALL DestructMatrix(vector)
    CALL DestructMatrix(vector2)
    CALL DestructMatrix(TempMat)
    CALL DestructMatrixMemoryPool(pool)
  END SUBROUTINE PowerBounds
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE EigenBoundsModule


module setup

    use numtype
    implicit none
    integer , parameter :: nsp = 311 , npar = 5
    integer :: minsp, maxsp, ifcal, iprint
    real (dp) :: yy(nsp), xx(nsp)

end module setup


text:
!! DEFAULT INITIALIZATION WITH VALID EMPTY CONSTRUCTOR REJECTED
!!
!! Fixed in 18.10
!!
!! This adds a final procedure for ITEM to pgi-dflt-init-1.f90
!!
!! $ pgfortran --version
!! pgfortran 18.4-0 64-bit target on x86-64 Linux -tp nehalem
!! $ pgfortran pgi-dflt-init-2.f90
!! PGF90-F-0155-Empty structure constructor() - type map (pgi-dflt-init-2.f90: 21)
!! PGF90/x86-64 Linux 18.4-0: compilation aborted

module map_type
  type :: item
    type(item), pointer :: next => null(), prev => null()
  contains
    final :: item_delete
  end type
  type :: map
    type(item), pointer :: first => null()
  end type
  type :: parameter_list
    type(map) :: params = map() ! VALID EMPTY CONSTRUCTOR REJECTED BY PGFORTRAN
  end type
contains
  subroutine item_delete(this)
    type(item), intent(inout) :: this
  end subroutine
end module

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


text:
PROGRAM F019

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    ! The first element is a dummy element.
    INTEGER, PARAMETER, DIMENSION(13) :: MONTH_CONSTANT = &
    (/ 0, 1, -1, 0, 0, 1, 1, 2, 3, 3, 4, 4, 5 /)

    INTEGER :: N = 0

    INTEGER :: DAY_VAL, I, J

    DO I = 1901, 2000

        DO J = 1, 12

            DAY_VAL =         (((I - 1) * 365) + FLOOR(REAL(I - 1) / 400.0)    &
                    + FLOOR(REAL(I - 1) / 4.0) - FLOOR(REAL(I - 1) / 100.0)    &
                    +          ((J - 1) *  30) + MONTH_CONSTANT(J) + 1)

            IF (MOD(I, 4) == 0 .AND. J > 2) DAY_VAL = DAY_VAL + 1

            DAY_VAL = MOD(DAY_VAL, 7)

            IF (DAY_VAL == 0) N = N + 1

        END DO

    END DO

    PRINT ('(I0)'), N

END PROGRAM F019

max_stars_repo_name: melwyncarlo/ProjectEuler

max_issues_repo_name: melwyncarlo/ProjectEuler

max_forks_repo_name: melwyncarlo/ProjectEuler


text:
      subroutine gradient(n, m, mxa, x, a, la, maxa, user, iuser, flag)

      use nonlin_types
      implicit none

        INCLUDE 'SLPCOMM.INC'

      integer n, m, mxa, maxa, iuser(*), la(0:*)
      integer flag
      double precision x(n), a(*), user(*)

      integer i, j, k, l, pjp, ll, p_a

      integer n_lt, n_nt, p_lti, p_nti, p_ltd, p_ntd, pcsi, pcsu,
     &     ix1, ix2, nx_pos

c     ... temporary gradient (for the nonlinear constraint)
      double precision c, tmpg(n)
      type(int_ll_el), pointer :: el

      include 'pusr.inc'

c     --------------- gradient of objective -----------------------

      mxa = maxa
      pjp = maxa+1
      la(pjp) = 1
      la(pjp+1) = n+1
      la(0) = pjp
      do i=1,n
         la(i) = i
         a(i) = 0.d0
      end do

      pcsi = iuser(pi_cs_pi+m+1)
      pcsu = iuser(pi_cs_pu+m+1)

      n_lt  = iuser(pcsi)
      n_nt  = iuser(pcsi+1)
      p_lti = iuser(pcsi+2)
      p_nti = iuser(pcsi+3)
      p_ltd = iuser(pcsi+4)
      p_ntd = iuser(pcsi+5)

      do i=1,n_lt
         ix1 = iuser(p_lti+i-1)
         a(ix1) = a(ix1) + user(p_ltd+i-1)
      end do

      do i=1,n_nt
         ix1 = iuser(p_nti+2*i-2)
         ix2 = iuser(p_nti+2*i-1)
         a(ix1) = a(ix1) + x(ix2)*user(p_ntd+i-1)
         a(ix2) = a(ix2) + x(ix1)*user(p_ntd+i-1)
      end do

c     -------------------- all other gradients -----------------------

      nx_pos = n+1

      do i=1,m-NLD%n_cs

         pcsi = iuser(pi_cs_pi+i)
         pcsu = iuser(pi_cs_pu+i)

         n_lt  = iuser(pcsi)
         n_nt  = iuser(pcsi+1)
         p_lti = iuser(pcsi+2)
         p_nti = iuser(pcsi+3)
         p_ltd = iuser(pcsi+4)
         p_ntd = iuser(pcsi+5)

         do j=1,n_lt
            ix1 = iuser(p_lti+j-1)
            a(nx_pos) = user(p_ltd+j-1)
            la(nx_pos) = ix1
            nx_pos = nx_pos + 1
         end do

         do j=1,n_nt
            ix1 = iuser(p_nti+2*j-2)
            ix2 = iuser(p_nti+2*j-1)
            a(nx_pos) = user(p_ntd+j-1)*x(ix2)
            la(nx_pos) = ix1
            nx_pos = nx_pos + 1
            a(nx_pos) = user(p_ntd+j-1)*x(ix1)
            la(nx_pos) = ix2
            nx_pos = nx_pos + 1
         end do
         la(pjp+i+1) = nx_pos

      end do

      do i=1,NLD%n_cs
c        we should fill in the next locations after nx_pos in the
c        la/a arrays. I guess the parser needs to count the number
c        of variables and their position.
         call get_gradient(NLD%root(i)%p, n, x, c, tmpg)

         el => NLD%ix_nz_cs(i)%p
         la(nx_pos) = el%ix
         a(nx_pos) = tmpg(el%ix)
         nx_pos = nx_pos + 1
         do j=2,NLD%n_nz_cs(i)
            el => el%next
            la(nx_pos) = el%ix
            a(nx_pos) = tmpg(el%ix)
            nx_pos = nx_pos + 1
         end do
         la(pjp+m-NLD%n_cs+i+1) = nx_pos
      end do

      end

max_stars_repo_name: ERGO-Code/FortranFilterSLP

max_issues_repo_name: ERGO-Code/FortranFilterSLP

max_forks_repo_name: ERGO-Code/FortranFilterSLP


program main
  external myfunc, myconstraint
  double precision lb(2)
  integer*8 opt
  double precision d1(2), d2(2)
  double precision x(2), minf
  integer ires
  include 'nlopt.f'

  opt=0
  call nlo_create(opt, NLOPT_LD_MMA, 2)
  call nlo_get_lower_bounds(ires, opt, lb)
  lb(2) = 0.0
  call nlo_set_lower_bounds(ires, opt, lb)
  call nlo_set_min_objective(ires, opt, myfunc, 0)

  d1(1) = 2.
  d1(2) = 0.
  call nlo_add_inequality_constraint(ires, opt, myconstraint, d1, 1.D-8)
  d2(1) = -1.
  d2(2) = 1.
  call nlo_add_inequality_constraint(ires, opt, myconstraint, d2, 1.D-8)

  call nlo_set_xtol_rel(ires, opt, 1.D-4)

  x(1) = 1.234
  x(2) = 5.678
  call nlo_optimize(ires, opt, x, minf)
  if (ires.lt.0) then
    write(*,*) 'nlopt failed!'
    stop 1
  else
    write(*,*) 'found min at ', x(1), x(2)
    write(*,*) 'min val = ', minf
  endif

  call nlo_destroy(opt)

  end

  subroutine myfunc(val, n, x, grad, need_gradient, f_data)
  double precision val, x(n), grad(n)
  integer n, need_gradient
  if (need_gradient.ne.0) then
     grad(1) = 0.0
     grad(2) = 0.5 / dsqrt(x(2))
  endif
  val = dsqrt(x(2))
  end

  subroutine myconstraint(val, n, x, grad, need_gradient, d)
  integer need_gradient
  double precision val, x(n), grad(n), d(2), a, b
  a = d(1)
  b = d(2)
  if (need_gradient.ne.0) then
    grad(1) = 3. * a * (a*x(1) + b)**2
    grad(2) = -1.0
  endif
  val = (a*x(1) + b)**3 - x(2)
  end