text:
cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
cdis
        subroutine mak_cld_grid (i4time_d,i4time_r,cg,ii,jj,kk,
     1                            lct,istatus)

c       $log: mak_cld_grid.for,v $
c revision 1.6  1995/09/13  21:36:15  birk
c added disclaimer to files
c
c revision 1.5  1994/09/09  15:53:09  birk
c  corrected mixed mode problem in pressure level assignment
c
c revision 1.4  1994/07/22  22:03:39  birk
c made code compatible with lapsparms.inc
c
c revision 1.3  1994/06/17  22:35:32  birk
c modification to peg cloud amount to upper limit of 1.0
c
c revision 1.2  1994/06/15  22:22:54  birk
c improved initialization
c
c revision 1.1  1994/04/25  15:11:00  birk
c initial revision
c

        implicit none

        include 'laps_cloud.inc'

	integer cloud_levels
	parameter (cloud_levels = kcloud)

	character*31 cloud_ext
	data cloud_ext/'lc3'/

c parameter variables

      integer ii,jj,kk
      integer lct

      integer i4time_d     !i4time of the desired grid
      integer i4time_r       !i4time of returned grid
      integer istatus
      real cg(ii,jj,kk)    !cloud grid (1=clear, 0=cloudy)

c variables dependent on dynamic allocation

      integer lvl(kk)
      real lma_ht(ii,jj,kk)
      real heights(ii,jj,kk)
      real clouds_3d(ii,jj,cloud_levels)
      real cld_pres(cloud_levels)

c internal variables

      integer i,j,k,l
      real cld_amt
      character*3 desired_field

c       threshold is dtermined by variable thresh
      save thresh
      real thresh
      data thresh /.65/
      real pressure_of_level !function call

c       initialize

        do k = 1,kk
        lvl(k) =  nint( pressure_of_level(k)  * .01 )
        enddo

        do k = 1,kk
        do j = 1,jj
        do i = 1,ii

        cg(i,j,k) = 0.  ! clear

        enddo
        enddo
        enddo

        desired_field = 'ht  '

        call get_maps_df (i4time_d,desired_field,lma_ht,
     1              ii,jj,kk,lct,istatus)

        if (istatus .ne. 1 ) return

        do k = 1,kk

        call bilinear_interp(ii,jj,lma_ht(1,1,k),ii,
     1   jj,heights(1,1,k),ii,jj)

        enddo

        call get_clouds_3dgrid(i4time_d,i4time_r,
     1  ii,jj,cloud_levels,cloud_ext,
     1  clouds_3d,cld_hts,cld_pres,istatus)

        if(istatus .ne. 1 ) return

        do k = 1,kk
        do j = 1,jj
        do i = 1,ii

        do l = 1,cloud_levels-1

        if (heights(i,j,k).gt.cld_hts(l)
     1  .and. heights(i,j,k).lt.cld_hts(l+1)) then

        call interp (heights(i,j,k),cld_hts(l),cld_hts(l+1),
     1  clouds_3d(i,j,l),clouds_3d(i,j,l+1),cld_amt)

c   ... added mod to limit cloud fraction to upper limit of 1.0

        if(cld_amt .gt. 1.) then
                cld_amt = 1
        endif

        cg(i,j,k) = cld_amt

        endif

        enddo

        enddo
        enddo
        enddo

        return
        end

max_stars_repo_name: maxinye/laps-mirror

max_stars_repo_licenses: Intel Unlicense OLDAP-2.2.1 NetCDF

max_issues_repo_name: longwosion/laps-mirror

max_issues_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense

max_forks_repo_name: longwosion/laps-mirror

max_forks_repo_licenses: Intel NetCDF OLDAP-2.2.1 Unlicense


text:
1     ASSIGN X TO 5
5     IF (X) 1, 2,3
2     X=-3
      GOTO 5
3     X=0
      GOTO 5
      END

ext: f

max_stars_repo_name: ElliotAlexander/EDSAC-FORTRAN-Compiler

max_issues_repo_name: ElliotAlexander/EDSAC-FORTRAN-Compiler

max_forks_repo_name: ElliotAlexander/EDSAC-FORTRAN-Compiler


text:
      SUBROUTINE SEQSDX(CARD,LUN)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SEQSDX
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION
C   FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A
C   USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY BUFR
C   ARCHIVE LIBRARY SUBROUTINE RDUSDX.  THESE ARE THEN ADDED TO THE
C   ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) WITHIN
C   THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN MODULE TABABD.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C                           ROUTINE "BORT"
C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C
C USAGE:    CALL SEQSDX (CARD, LUN)
C   INPUT ARGUMENT LIST:
C     CARD     - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ
C                FROM A USER-SUPPLIED BUFR DICTIONARY TABLE
C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C
C REMARKS:
C    THIS ROUTINE CALLS:        ADN30    BORT2    NEMOCK   NEMTAB
C                               NUMTAB   PARSTR   PKTDD    RSVFVM
C                               STRNUM
C    THIS ROUTINE IS CALLED BY: RDUSDX
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5)

      CHARACTER*128 BORT_STR1,BORT_STR2
      CHARACTER*80  CARD,SEQS
      CHARACTER*12  ATAG,TAGS(250)
      CHARACTER*8   NEMO,NEMA,NEMB
      CHARACTER*6   ADN30,CLEMON
      CHARACTER*3   TYPS
      CHARACTER*1   REPS,TAB

      DATA MAXTGS /250/
      DATA MAXTAG /12/

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C  FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING
C  --------------------------------------------------------------

      NEMO = CARD( 3:10)
      SEQS = CARD(14:78)

C     Note that an entry for this mnemonic should already exist within
C     the internal BUFR Table D array TABD(*,LUN); this entry should
C     have been created by subroutine RDUSDX when the mnemonic and its
C     associated FXY value and description were initially defined
C     within a card read from the "Descriptor Definition" section at
C     the top of the user-supplied BUFR dictionary table in character
C     format.  Now, we need to retrieve the positional index for that
C     entry within TABD(*,LUN) so that we can access the entry and then
C     add the decoded sequence information to it.

      CALL NEMTAB(LUN,NEMO,IDN,TAB,ISEQ)
      IF(TAB.NE.'D') GOTO 900
      CALL PARSTR(SEQS,TAGS,MAXTGS,NTAG,' ',.TRUE.)
      IF(NTAG.EQ.0 ) GOTO 901

      DO N=1,NTAG
      ATAG = TAGS(N)
      IREP = 0

C  CHECK FOR REPLICATOR
C  --------------------

      DO I=1,5
      IF(ATAG(1:1).EQ.REPS(I,1)) THEN

C        Note that REPS(*,*), which contains all of the symbols used to
C        denote all of the various replication schemes that are
C        possible within a user-supplied BUFR dictionary table in
C        character format, was previously defined within subroutine
C        BFRINI.

         DO J=2,MAXTAG
         IF(ATAG(J:J).EQ.REPS(I,2)) THEN
            IF(J.EQ.MAXTAG) GOTO 902

C           Note that subroutine STRNUM will return NUMR = 0 if the
C           string passed to it contains all blanks (as *should* be the
C           case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or
C           5 '<' '>').

C           However, when I = 1 '"' '"', then subroutine STRNUM will
C           return NUMR = (the number of replications for the mnemonic
C           using F=1 "regular" (i.e. non-delayed) replication).

            CALL STRNUM(ATAG(J+1:MAXTAG),NUMR)
            IF(I.EQ.1 .AND. NUMR.LE.0  ) GOTO 903
            IF(I.EQ.1 .AND. NUMR.GT.255) GOTO 904
            IF(I.NE.1 .AND. NUMR.NE.0  ) GOTO 905
            ATAG = ATAG(2:J-1)
            IREP = I
            GOTO 1
         ENDIF
         ENDDO
         GOTO 902
      ENDIF
      ENDDO

C  CHECK FOR VALID TAG
C  -------------------

1     IRET=NEMOCK(ATAG)
      IF(IRET.EQ.-1) GOTO 906
      IF(IRET.EQ.-2) GOTO 907
      CALL NEMTAB(LUN,ATAG,IDN,TAB,IRET)
      IF(IRET.GT.0) THEN

C        Note that the next code line checks that we are not trying to
C        replicate a Table B mnemonic (which is currently not allowed).
C        The logic works because, for replicated mnemonics, IREP = I =
C        (the index within REPS(*,*) of the symbol associated with the
C        type of replication in question (e.g. "{, "<", etc.))

         IF(TAB.EQ.'B' .AND. IREP.NE.0) GOTO 908
         IF(ATAG(1:1).EQ.'.') THEN

C           This mnemonic is a "following value" mnemonic
C           (i.e. it relates to the mnemonic that immediately
C           follows it within the user-supplied character-format BUFR
C           dictionary table sequence), so confirm that it contains, as
C           a substring, this mnemonic that immediately follows it.

            NEMB = TAGS(N+1)
c  .... get NEMA from IDN
            CALL NUMTAB(LUN,IDN,NEMA,TAB,ITAB)
            CALL NEMTAB(LUN,NEMB,JDN,TAB,IRET)
            CALL RSVFVM(NEMA,NEMB)
            IF(NEMA.NE.ATAG) GOTO 909
c  .... DK: I don't think the next test can ever be satisfied
c  ....     should probably be IF(N.EQ.NTAG ) GOTO 910
            IF(N.GT.NTAG ) GOTO 910
            IF(TAB.NE.'B') GOTO 911
         ENDIF
      ELSE
         GOTO 912
      ENDIF

C  WRITE THE DESCRIPTOR STRING INTO TABD ARRAY
C  -------------------------------------------
c  .... first look for a replication descriptor
      IF(IREP.GT.0) CALL PKTDD(ISEQ,LUN,IDNR(IREP,1)+NUMR,IRET)
      IF(IRET.LT.0) GOTO 913
      CALL PKTDD(ISEQ,LUN,IDN,IRET)
      IF(IRET.LT.0) GOTO 914

      ENDDO

C  EXITS
C  -----

      RETURN
900   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '//
     . '(UNDEFINED, TAB=",A,")")') NEMO,TAB
      CALL BORT2(BORT_STR1,BORT_STR2)
901   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') NEMO
      CALL BORT2(BORT_STR1,BORT_STR2)
902   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
903   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
     . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'//
     . ' 2ND QUOTE")') NEMO,TAGS(N),NUMR
      CALL BORT2(BORT_STR1,BORT_STR2)
904   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
     . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '//
     . '255")') NEMO,TAGS(N),NUMR
      CALL BORT2(BORT_STR1,BORT_STR2)
905   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'//
     . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'//
     . 'NO")') NEMO,TAGS(N),NUMR
      CALL BORT2(BORT_STR1,BORT_STR2)
906   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")')
     . NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
907   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
908   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
     . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")')
     . NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
909   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '//
     . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")')
     . NEMO,TAGS(N),NEMA
      CALL BORT2(BORT_STR1,BORT_STR2)
910   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '//
     . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '//
     . 'STRING")') NEMO,NEMA
      CALL BORT2(BORT_STR1,BORT_STR2)
911   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'//
     . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '//
     . 'ENTRY")') NEMO,NEMB
      CALL BORT2(BORT_STR1,BORT_STR2)
912   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
     . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")')
     .  NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
913   CLEMON = ADN30(IDNR(IREP,1)+NUMR,6)
      WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
     . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '//
     . 'WARNING MSG")') NEMO,CLEMON
      CALL BORT2(BORT_STR1,BORT_STR2)
914   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
      WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
     . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '//
     . 'WARNING MSG")') NEMO,TAGS(N)
      CALL BORT2(BORT_STR1,BORT_STR2)
      END


text:
SUBROUTINE RINT13(REL,A,B,X,Y,S,JATOM)
  use potnlc
  use xrpar
  !
  !LO S = INT { AX + CIN BY } = INT { AX + (1/ALPHA) BY }
  !LO
  INCLUDE 'param.inc'
  IMPLICIT REAL*8 (A-H,O-Z)
  LOGICAL REL
  DIMENSION A(NRAD),B(NRAD),X(NRAD),Y(NRAD)
  !      COMMON /POTNLC/ Z(NRAD),RNOT(NATO),DX(NATO),JRI(NATO)
  D=EXP(DX(JATOM))
  if (xmcd.eq.1) then
     CIN=7.29927D-3    ! for core, CIN=ALPHA=1/137
  else
     CIN=1.331258D-5   ! CIN=1/137^2
     IF(.NOT.REL) CIN=1E-22
     CIN=CIN*4
  endif
  !       CIN=1.0D0
  !      IF(.NOT.REL) CIN=1E-22
  !
  !     CONVERT FROM RYDBERG TO HARTREE UNITS
  !
  !      CIN=CIN*4
  J=3-MOD(JRI(JATOM),2)
  J1=J-1
  R=RNOT(JATOM)*(D**(J-1))
  R1=R/D
  Z4=0
  Z2=0
10 Z4=Z4+R*(A(J)*X(J)+CIN*B(J)*Y(J))
  R=R*D
  J=J+1
  IF(J.GE.JRI(JATOM)) GOTO 20
  Z2=Z2+R*(A(J)*X(J)+CIN*B(J)*Y(J))
  R=R*D
  J=J+1
  GOTO 10
20 P1=RNOT(JATOM)*(A(1)*X(1)+CIN*B(1)*Y(1))
  P2=R1*(A(J1)*X(J1)+CIN*B(J1)*Y(J1))
  S=2*Z2+4*Z4+R*(A(J)*X(J)+CIN*B(J)*Y(J))+P2
  S=(DX(JATOM)*S+P1)/3.0D0
  IF(J1.GT.1) S=S+0.5D0*DX(JATOM)*(P1+P2)
  RETURN
END SUBROUTINE RINT13


text:
!!
!! Update: Now working in 16.1.1.2
!!
!! This example should procdue this output
!!
!!   any_scalar constructor
!!   any_scalar constructor
!!   returning stat= 1
!!
!! (the stat=1 is correct!) and exit with a 0 status code. But it will
!! often -- but not always! -- produce a segfault after the output. Notice
!! that the traceback shows the ANY_VECTOR constructor. That code should
!! never be called in this example! Using version 16.1.1 RC3 on power9.
!!
!! $ xlf2008 -g ibm-20181201.f90
!! ** map_any_type   === End of Compilation 1 ===
!! ** parameter_entry_class   === End of Compilation 2 ===
!! ** parameter_list_type   === End of Compilation 3 ===
!! ** main   === End of Compilation 4 ===
!! 1501-510  Compilation successful for file ibm-20181201.f90.
!! !! often -- but not always -- segfault after producing the output. with
!! !! this traceback
!!
!! $ ./a.out
!!  any_scalar constructor
!!  any_scalar constructor
!!  returning stat= 1
!!
!!   Signal received: SIGSEGV - Segmentation violation
!!
!!   Traceback:
!!     Offset 0x000000c0 in procedure _xlfN10any_vectorD1scalar, near line 87 in
!! file ibm-20181201.f90
!!     Location 0x000020000018b57c
!!     Offset 0x00000088 in procedure
!! __parameter_entry_class_NMOD__xlfN10any_vectorD1, near line 81 in file
!! ibm-20181201.f90
!!     Offset 0x000007b8 in procedure __parameter_list_type_NMOD_set_vector, near
!! line 128 in file ibm-20181201.f90
!!     Offset 0x000001d4 in procedure test_basic, near line 149 in file
!! ibm-20181201.f90
!!     Offset 0x00000028 in procedure main, near line 143 in file ibm-20181201.f90
!!     Location 0x0000200000c950fc
!!     Location 0x0000200000c952f0
!!     --- End of call chain ---

module map_any_type
  type :: map_any
  contains
    procedure :: insert
  end type
contains
  subroutine insert (this, key, value)
    class(map_any), intent(inout) :: this
    character(*), intent(in) :: key
    class(*), intent(in) :: value
  end subroutine
end module

module parameter_entry_class
  type, abstract :: parameter_entry
  end type
  type, extends(parameter_entry) :: any_scalar
    class(*), allocatable :: value
  end type
  interface any_scalar
    procedure any_scalar_value
  end interface
  type, extends(parameter_entry) :: any_vector
    class(*), allocatable :: value(:)
  end type
  interface any_vector
    procedure any_vector_value
  end interface
contains
  function any_scalar_value(value) result(obj)
    class(*), intent(in) :: value
    type(any_scalar) :: obj
    print *, 'any_scalar constructor'
    allocate(obj%value, source=value)
  end function
  function any_vector_value(value) result(obj)
    class(*), intent(in) :: value(:)
    type(any_vector) :: obj
    print *, 'any_vector constructor'
    allocate(obj%value, source=value)
  end function
end module

module parameter_list_type
  use parameter_entry_class
  use map_any_type
  type :: parameter_list
    type(map_any) :: params = map_any()
  contains
    generic :: set => set_scalar, set_vector
    procedure, private :: set_scalar
    procedure, private :: set_vector
  end type
contains

  subroutine set_scalar(this, name, value)
    class(parameter_list), intent(inout) :: this
    character(*), intent(in) :: name
    class(*), intent(in) :: value
    call this%params%insert(name, any_scalar(value))
  end subroutine

  subroutine set_vector (this, name, value, stat)
    class(parameter_list), intent(inout) :: this
    character(*), intent(in) :: name
    class(*), intent(in) :: value(:)
    integer, intent(out) :: stat
    class(parameter_entry), pointer :: pentry
    stat = 0
    pentry => find_entry(this%params, name)
    if (associated(pentry)) then
      select type (pentry)
      type is (any_vector)
      class default ! THIS BRANCH IS EXECUTED
        stat = 1
        print *, 'returning stat=', stat
      end select
    else ! THIS BRANCH NOT EXECUTED
      print *, 'in wrong branch'
      call this%params%insert(name, any_vector(value))
    end if
  end subroutine

  function find_entry(map, name) result(pentry)
    class(map_any), intent(in) :: map
    character(*), intent(in) :: name
    class(parameter_entry), pointer :: pentry
    allocate(pentry, source=any_scalar(42))
  end function find_entry

end module

program main
  use parameter_list_type
  call test_basic
contains
  subroutine test_basic
    type(parameter_list) :: p
    integer ::stat
    call p%set('foo', 1)
    call p%set('foo', [1,2], stat)
    if (stat == 0) stop 1
  end subroutine
end program

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


program Wavelets
    use fixed_array
    use zfp_array
    use wavelet
    use lz4
    use, intrinsic :: ieee_arithmetic
    implicit none

    integer(kind=4), parameter :: N = 4
    integer i, j

    real(kind=4), dimension(N, N) :: x, x_in
    real(kind=4), dimension(N, N) :: y
    logical(kind=1), dimension(N, N) :: mask
    character(kind=c_char), allocatable :: mask_buffer(:)
    character(kind=c_char), allocatable :: array_buffer(:)

    type(fixed_block), dimension(N/4, N/4) :: compressed
    type(fixed_block) :: compressed_block
    integer :: x1, x2, y1, y2
    integer :: max_exp

    integer, dimension(4, 4) :: e

    ! FORTRAN-native ZFP
    type(zfp_block) :: compressed2
    integer(kind=2) :: bitmask

    do i = 1, N
        do j = 1, N
            x(i, j) = i*j
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    print *, 'BEFORE'
    do i = 1, N
        print *, x(i, :)
    end do

    ! a forward 2D wavelet transform
    call daub4_2Dtransform(N, x, y, mask)

    ! count the number of 0.0 coefficients
    print *, '# of zero coefficients:', count(y .eq. 0.0)

    print *, 'AFTER'
    do i = 1, N
        print *, y(i, :)
    end do

    ! an inverse transform to recover the data
    call daub4_2Dtransform_inv(N, y, x, mask)

    print *, 'RECOVERED'
    do i = 1, N
        print *, x(i, :)
    end do

    ! reset the source
    do i = 1, N
        do j = 1, N
            x(i, j) = (i - 2)*(j - 2)/10.0
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    print *, 'X:'
    do i = 1, N
        print *, x(i, :)
    end do

    ! an in-place transform
    call daub4_2Dtransform_inpl(n, x, mask)

    ! count the number of 0.0 coefficients
    print *, '# of zero coefficients:', count(x .eq. 0.0)

    print *, 'MASK'
    do i = 1, N
        print *, mask(i, :)
    end do

    print *, 'COEFFS:'
    do i = 1, N
        print *, x(i, :)
    end do

    ! an in-place inverse transform
    call daub4_2Dtransform_inv_inpl(n, x, mask)

    print *, 'RECOVERED'
    do i = 1, N
        print *, x(i, :)
    end do

    ! ZFP-like fixed-point 4x4 block with a common exponent

    ! reset the source
    do i = 1, N
        do j = 1, N
            x(i, j) = (i - 2)*(j - 2)/1000.0
        end do
    end do

    ! insert a NaN value
    x(N/2, N/2) = ieee_value(0.0, ieee_quiet_nan)

    !  pick out all the NaN
    where (isnan(x))
        mask = .false.
    elsewhere
        mask = .true.
    end where

    ! replace NaNs with 0.0
    ! where (.not. mask) x = 0.0

    print *, 'minexponent', minexponent(0.0)
    print *, 'e', exponent(x)

    ! ZFP-like compression
    call to_fixed(x, compressed, -1000.0, -100.0, 100.0, minval(x), maxval(x))

    call print_fixed_block(compressed(1, 1))

    ! testing irregular blocks
    x1 = 1
    x2 = 4
    y1 = 1
    y2 = 4

    x_in = ieee_value(0.0, ieee_quiet_nan)
    x_in(x1:x2, y1:y2) = x(x1:x2, y1:y2)

    print *, 'x_in'
    do i = 1, N
        print *, x_in(i, :)
    end do

    e = exponent(x)
    max_exp = minexponent(0.0)

    do j = 1, 4
        do i = 1, 4
            if (.not. isnan(x(i, j))) then
                ! ignore zero values when looking for the maximum exponent
                if (abs(x(i, j)) .gt. 0.0) then
                    if (e(i, j) .gt. max_exp) then
                        max_exp = e(i, j)
                        print *, 'x', x(i, j), 'e', e(i, j), 'max_exp', max_exp
                    end if
                end if
            end if
        end do
    end do

    print *, 'block max_exp', max_exp

    ! call to_fixed_block(x_in, compressed_block)
    ! call from_fixed_block(compressed_block, x)

    print *, 'sizeof(x):', sizeof(x), ', compressed size:', sizeof(compressed)
    print *, 'compression ratio:', real(sizeof(x))/real(sizeof(compressed))

    ! call LZ4-HC to compress the mask
    ! call compress_mask(mask, mask_buffer)

    ! compress the fixed array
    ! call compress_fixed_array(compressed, array_buffer)

    ! decompress mask
    ! call decompress_mask(mask_buffer, mask)

    ! call decompress_fixed_array(array_buffer, compressed)

    ! ZFP-like decompression
    call from_fixed(N, compressed, x, minval(x), maxval(x))

    ! insert back NaN values
    ! where (.not. mask) x = ieee_value(0.0, ieee_quiet_nan)

    print *, 'FIXED-POINT DECOMPRESSION'
    do i = 1, N
        print *, x(i, :)
    end do

    print *, compressed
    print *, mask

    call zfp_compress_block(x, compressed2)
    call zfp_decompress_block(compressed2, x, bitmask)

    print *, 'native ZFP decompression', x
    write (*, '(a,b32.32)') 'bitmask ', bitmask

end program Wavelets


text:
SUBROUTINE SAMPLE02

    DO NK=0,NFRAC*(NNODE-1)-1
        n = nk/(nnode-1)+1
        k = mod(nk,nnode-1)+2
        SUM = SUM + 5
    END DO

    RETURN
END

max_stars_repo_name: xevolver/xevxml

max_issues_repo_name: xevolver/xevxml

max_forks_repo_name: xevolver/xevxml


text:
!Routine to fill data gaps in a series
!Input:
!       time: the time series that is not linear in time
!       dt: expected time lag between succesive observations
!       tol: tolerance for dt
!       ai: A series to fill in the gaps alongside the time series
!       ln: length of ai
!       nmd: an approximation to extend the current length of time and ai by to
!       account for filling in the time gaps
!       fillval: the value to fill into ai when gaps are filled in time
!Output:
!       tn: filled time series
!       dn: filled ai series

subroutine fill_gaps(time, dt, tol, ai, ln, nmd, fillval, tn, dn,counter)
   double precision, intent(in) :: fillval, dt, tol
   integer*8, intent(in) :: ln, nmd
   integer*8, intent(out) :: counter
   double precision, intent(in), dimension(ln) :: ai, time
   double precision, intent(out), dimension(ln+nmd*2) :: tn, dn
   integer*8 :: i
   double precision :: del
   counter = 0
   do i=1,ln
      del = time(i+1) - time(i)
      if (abs(del-dt) <= tol) then
         dn(counter) = ai(i)
         tn(counter) = time(i)
         counter = counter + 1
      else
         do while (abs(time(i+1) - tn(counter-1)) > dt+tol)
            if (tn(counter-1)+dt > time(i+1)) then
               EXIT
            else
               tn(counter) = tn(counter-1)+dt
               dn(counter) = fillval
               counter = counter + 1
            endif
         enddo
      endif
   enddo
end subroutine fill_gaps

max_stars_repo_name: tulasinandan/TurbAn

max_issues_repo_name: tulasinandan/TurbAn

max_forks_repo_name: tulasinandan/TurbAn


text:
! Modified to add f_quartic and fprime_quartic for quartic function,
! and to add epsilon as a module variable.

module functions

    implicit none
    real(kind=8) :: epsilon
    save

contains

real(kind=8) function f_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_sqrt = x**2 - 4.d0

end function f_sqrt

real(kind=8) function fprime_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_sqrt = 2.d0 * x

end function fprime_sqrt

real(kind=8) function f_quartic(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_quartic = (x - 1.d0)**4 - epsilon

end function f_quartic

real(kind=8) function fprime_quartic(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_quartic = 4.d0 * (x - 1.d0)**3

end function fprime_quartic

end module functions

max_stars_repo_name: philipwangdk/HPC

max_issues_repo_name: philipwangdk/HPC

max_forks_repo_name: philipwangdk/HPC


text:
      subroutine steer(choice,num)
c Choice = 1 for 1996 and 2 for 1997
	implicit none

#include "local.inc"
	integer null,choice,num,num2,num3
	character*1 a,b,c
	character*9 fname, fname2
        character(len = 12) cardspath

	if (num.le.9) then
        write (a,'(i1)') num
        fname = 'st961_'//a
	  fname2 = 'st971_'//a
	else if (num.gt.9.and.num.le.18) then
	  num2 = num-9
        write (b,'(i1)') num2
        fname = 'st962_'//b
        fname2 = 'st972_'//b
	else if (num.gt.18.and.num.le.26) then
	  num3 = num-18
        write (c,'(i1)') num3
        fname = 'st963_'//c
        fname2 = 'st973_'//c
	end if

	if (choice.eq.1) then
        cardspath = '../cards/96/'
        write(*,*) 'Reading steering card from ',cardspath//fname
        write(999,*) 'Reading steering card from ',cardspath//fname
        open(unit=20,file=cardspath//fname,status='old')
	read(20,*,err=90) null
	read(20,*,err=90) lumiscale
	read(20,*,err=90) lumires
	read(20,*,err=90) enelow
	read(20,*,err=90) elglow
	read(20,*,err=90) empztothigh
	read(20,*,err=90) empztotlow
	read(20,*,err=90) empzcalcard
	read(20,*,err=90) zvertex
	read(20,*,err=90) bgdnormal
	read(20,*,err=90) boxcutcard1
	read(20,*,err=90) tag44mveto
	read(20,*,err=90) hadscale
	read(20,*,err=90) elenscale
	read(20,*,err=90) offlineuse
	read(20,*,err=90) bkspuse
	read(20,*,err=90) ybinhigh
	read(20,*,err=90) ybinlow
	read(20,*,err=90) srtdpressc
	read(20,*,err=90) diffractiv

90	continue
	close(20)
	end if

      if (choice.eq.2) then
        cardspath = '../cards/97/'
        write(*,*) 'Reading steering card from ',cardspath//fname2
        write(999,*) 'Reading steering card from ',cardspath//fname2
        open(unit=20,file=cardspath//fname2,status='old')
	read(20,*,err=80) null
	read(20,*,err=80) lumiscale
	read(20,*,err=80) lumires
	read(20,*,err=80) enelow
	read(20,*,err=80) elglow
	read(20,*,err=80) empztothigh
	read(20,*,err=80) empztotlow
	read(20,*,err=80) empzcalcard
	read(20,*,err=80) zvertex
	read(20,*,err=80) bgdnormal
	read(20,*,err=80) boxcutcard1
	read(20,*,err=80) tag44mveto
	read(20,*,err=80) hadscale
	read(20,*,err=80) elenscale
	read(20,*,err=80) offlineuse
	read(20,*,err=80) bkspuse
	read(20,*,err=80) ybinhigh
	read(20,*,err=80) ybinlow
	read(20,*,err=80) srtdpressc
	read(20,*,err=80) diffractiv

80	continue
	close(20)
	end if

	write(*,*) '------------------------------------------'
	write(*,*) '    Steering parameters for F2ISR         '
	write(*,*) ' '
	write(*,*) ' Lumi energy scale :',lumiscale
	write(*,*) ' Lumi res :',lumires
	write(*,*) ' Electron en lower cut:',enelow
	write(*,*) ' Lumi photon energy lower cut:',elglow
	write(*,*) ' empztot upper cut :',empztothigh
	write(*,*) ' empztot lower cut :',empztotlow
	write(*,*) ' empz cal cut :',empzcalcard
	write(*,*) ' z vertex cut :',zvertex
	write(*,*) ' bgd normalisation e-pz:',bgdnormal
	write(*,*) ' Do boxcut +- 0.5:',boxcutcard1
	write(*,*) ' Do 44m Tagger veto:',tag44mveto
	write(*,*) ' Had energy scale :',hadscale
	write(*,*) ' electron energy scale :',elenscale
	write(*,*) ' offline trigger:',offlineuse
	write(*,*) ' backsplash :',bkspuse
	write(*,*) ' y bin high:',ybinhigh
	write(*,*) ' y bin low:',ybinlow
	write(*,*) ' srtd pres scale:',srtdpressc
	write(*,*) ' diffractive frac:',diffractiv
	write(*,*) ' '
	write(*,*) '-----------------------------------------'

 	write(999,*) '------------------------------------------'
	write(999,*) '    Steering parameters for F2ISR         '
	write(999,*) ' '
	write(999,*) ' Lumi energy scale :',lumiscale
	write(999,*) ' Lumi res :',lumires
	write(999,*) ' Electron en lower cut:',enelow
	write(999,*) ' Lumi photon energy lower cut:',elglow
	write(999,*) ' empztot upper cut :',empztothigh
	write(999,*) ' empztot lower cut :',empztotlow
	write(999,*) ' empz cal cut :',empzcalcard
	write(999,*) ' z vertex cut :',zvertex
	write(999,*) ' bgd normalisation e-pz:',bgdnormal
	write(999,*) ' Do boxcut +- 0.5:',boxcutcard1
	write(999,*) ' Do 44m Tagger veto:',tag44mveto
	write(999,*) ' Had energy scale :',hadscale
	write(999,*) ' electron energy scale :',elenscale
	write(999,*) ' offline trigger:',offlineuse
	write(999,*) ' backsplash :',bkspuse
	write(999,*) ' y bin high:',ybinhigh
	write(999,*) ' y bin low:',ybinlow
	write(999,*) ' srtd pres scale:',srtdpressc
	write(999,*) ' diffractive frac:',diffractiv
	write(999,*) ' '
	write(999,*) '-----------------------------------------'

	return
	end

ext: fpp


text: Robert Dynes is the 20th president of the UC system, and after a tenure plagued with scandals, announced his resignation in 2007.  He was replaced by Mark Yudof.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
module timedisc_types_mod

use constants_mod

type :: auxiliary_timedisc_t
# if PP_N_DIMS == 2
    real(dp) ::  register0(N_NODES,N_NODES,N_VARS)
    real(dp) ::  register1(N_NODES,N_NODES,N_VARS)

# elif PP_N_DIMS == 3
    real(dp) ::  register0(N_NODES,N_NODES,N_NODES,N_VARS)
    real(dp) ::  register1(N_NODES,N_NODES,N_NODES,N_VARS)

# else
# error: unknown PP_N_DIMS
# endif
end type

end module

max_stars_repo_name: jmark/nemo

max_issues_repo_name: jmark/nemo

max_forks_repo_name: jmark/nemo


text:
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

program elastic

  use libAtoms_module
  use elasticity_module, only: elastic_fields

  implicit none

  type(Atoms) :: at
  type(CInoutput) :: infile, outfile
  type(Dictionary) :: params
  integer :: i, n, iostat, nargs
  character(len=2048) :: comment, arg1, arg2, missing_params
  real(dp) :: a, C11, C12, C44, l_cutoff, nneightol

  call system_initialise(PRINT_SILENT)
  call verbosity_push(PRINT_NORMAL)

  call initialise(params)

  call param_register(params, 'a', PARAM_MANDATORY, a, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'C11', PARAM_MANDATORY, C11, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'C12', PARAM_MANDATORY, C12, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'C44', PARAM_MANDATORY, C44, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'cutoff', '5.0', l_cutoff, help_string="No help yet.  This source file was $LastChangedBy$")
  call param_register(params, 'nneightol', '1.2', nneightol, help_string="No help yet.  This source file was $LastChangedBy$")

  nargs = cmd_arg_count()

  if (nargs < 2) then
     call print('Usage: elastic_fields <infile> <outfile> [params]')
     call print('')
     call print('Parameters and default values are:')
     call param_print(params)
     call verbosity_push(PRINT_SILENT)
     call system_finalise()
     stop
  end if

  call get_cmd_arg(1, arg1)
  call get_cmd_arg(2, arg2)

  call initialise(infile, arg1)
  call initialise(outfile, arg2, action=OUTPUT)

  if (nargs > 2) then
     if (.not. param_read_args(params, (/ (i, i=3,nargs ) /))) &
          call system_abort('Error parsing command line')
  end if

  if (.not. param_check(params, missing_params)) &
       call system_abort('Missing mandatory parameters: '//missing_params)

  call print('Parameters:')
  call param_print(params)
  call print('')

  ! Loop over all frames in input file
  do n=0,infile%n_frame-1
     call read(infile, at, frame=n)

     call print('Frame '//n)

     call set_cutoff(at, l_cutoff)
     at%nneightol = nneightol

     call elastic_fields(at, a, C11, C12, C44)
     call write(outfile, at)
  end do
  call print('Done '//n//' frames!')

  call verbosity_push(PRINT_SILENT)
  call system_finalise

end program elastic

max_stars_repo_name: albapa/QUIP

max_issues_repo_name: albapa/QUIP

max_forks_repo_name: albapa/QUIP


text:
* FORTRAN test file to implement the DATA statement
* This file uses the DATA statement to assign arrays using implied DO loops
* Constructs of these types are yet to be handled and will be implemented if
* need be
**********************************************************************
* Expected Output: A:
*                  1.0  3.0
*				   2.0  4.0
*
*				   R:
*			   	   1.0  1.0
*			       1.0  1.0
*			       1.0  1.0
*
*			       S:
*			       1.0  0.0  0.0  0.0
*			       0.0  1.0  0.0  0.0
*			       0.0  0.0  1.0  0.0
*			       0.0  0.0  0.0  1.0
*
*			       B:
*			       1.1  2.1
*			       3.1  4.1
*
*			       C:
*			       2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0  2.0
*
*			       MATRIX:
*			       1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  0.0  1.0
*			       1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0  1.0
**********************************************************************

      PROGRAM MAIN

      IMPLICIT NONE

      REAL, DIMENSION(10) :: C
      REAL, DIMENSION(3,2) :: R
      REAL, DIMENSION(4,4) :: S

      INTEGER :: I, J
      REAL, DIMENSION(10,10) :: MATRIX

      DATA (C(I), I=1,10) /10*2.0/
      DATA ((R(I,J),J=1,2),I=1,3) /6*1.0/
      DATA (S(I,I), I=1,4) /4*1.0/

      DATA MATRIX(1,    1:10) / 10*1.0  / ! TOP ROW
      DATA MATRIX(10,  1:10) / 10*1.0  / ! BOT ROW
      DATA MATRIX(2:9, 1)     / 8*1.0   / ! LEFT COL
      DATA MATRIX(2:9, 10)   / 8*1.0   / ! RIGHT COL
      DATA MATRIX(2:9, 2:9)  / 64*0.0 / ! INTERIOR

      WRITE (*,11)
      WRITE (*,12) 'R: '
      DO I = 1, 3
          WRITE (*,20) R(I,1), R(I,2)
      END DO

      WRITE (*,11)
      WRITE (*,12) 'S: '
      DO I = 1, 4
          WRITE (*,30) S(I,1), S(I,2), S(I,3), S(I,4)
      END DO

      WRITE (*,11)
      WRITE (*,12) 'C: '
      WRITE (*,40) C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9),
     &             C(10)

      WRITE (*,11)
      WRITE (*,12) 'MATRIX: '
      DO I = 1, 10
          WRITE (*,40) MATRIX(I,1), MATRIX(I,2), MATRIX(I,3),
     &          MATRIX(I,4), MATRIX(I,5), MATRIX(I,6), MATRIX(I,7),
     &          MATRIX(I,8), MATRIX(I,9), MATRIX(I,10)
      END DO

 11   FORMAT('')
 12   FORMAT(A)
 20   FORMAT(2(F3.1,2X))
 30   FORMAT(4(F3.1,2X))
 40   FORMAT(10(F3.1,2X))

      END PROGRAM MAIN


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

C $Log: ptsnrm.f,v $
C Revision 1.2  2009/03/25 12:36:46  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.1  1994/04/07 20:08:16  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.2  1990/12/14  08:55:30  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE PTSNRM( PLAPTS, INPT,  CUTPT, CUTNRM , IERR)
C=======================================================================

C   --*** PTRNRM *** (MESH) Turns three point plane to point-normal form
C   --   Written by Ray J. Meyers 29 May, 1990
C   --
C   -- Given three non-colinear points, returns a description of the plane
C   -- consisting of a point on the plane and a normal vector to the plane.
C   --
C   --Parameters:
C   --   PLAPTS - IN - the 3 points defining the cutting plane;
C   --   INPT - IN - a point in the mesh, ie, on the opposite side
C                    from the cutting plane normal
C   --   CUTPT - OUT - a point on the cutting plane;
C   --   CUTNRM - OUT - the normal to the cutting plane;
C   --   IERR - OUT - non-zero if the input points are colinear (no plane
C                     defined)

      REAL PLAPTS(3,3)
      REAL INPT(3)
      REAL CUTPT(3)
      REAL CUTNRM(3)
      INTEGER IERR
      REAL VEC1(3), VEC2(3)
      REAL TOL, DOT
C
C DEFINE TWO VECTORS IN THE PLANE : VEC1 = P1-P2, VEC2 = P3-P2
C
      VEC1(1) = PLAPTS(1,1) - PLAPTS(1,2)
      VEC1(2) = PLAPTS(2,1) - PLAPTS(2,2)
      VEC1(3) = PLAPTS(3,1) - PLAPTS(3,2)
      VEC2(1) = PLAPTS(1,3) - PLAPTS(1,2)
      VEC2(2) = PLAPTS(2,3) - PLAPTS(2,2)
      VEC2(3) = PLAPTS(3,3) - PLAPTS(3,2)
C
C DEFINE A TOLERANCE BASED ON THE LENGTH OF  VEC1
C
      TOL = 1E-06 * AMAX1 ( VEC1(1), VEC1(2), VEC1(3) )
C
C TAKE THE CROSS PRODUCT OF VEC1 AND VEC2 AS THE NORMAL OF THE PLANE AND
C NORMALIZE
C
      CUTNRM(1) = VEC1(2)*VEC2(3) - VEC1(3)*VEC2(2)
      CUTNRM(2) = VEC1(3)*VEC2(1) - VEC1(1)*VEC2(3)
      CUTNRM(3) = VEC1(1)*VEC2(2) - VEC1(2)*VEC2(1)

      DIST = SQRT( CUTNRM(1)*CUTNRM(1) + CUTNRM(2)*CUTNRM(2) +
     $             CUTNRM(3)*CUTNRM(3) )
      CUTNRM(1) = CUTNRM(1)/DIST
      CUTNRM(2) = CUTNRM(2)/DIST
      CUTNRM(3) = CUTNRM(3)/DIST

C
C IF THE NORMAL IS (0,0,0), THE ORIGINAL POINTS WERE COLINEAR
C
      IF( ABS(CUTNRM(1)) .LT. TOL .AND. ABS(CUTNRM(2)) .LT. TOL
     $    .AND. ABS(CUTNRM(3)) .LT. TOL) THEN
          CALL PRTERR ('CMDERR', 'Points do not define a plane')
          IERR = 1
      ELSE
          IERR = 0
C
C USE THE SECOND INPUT POINT AS THE CHOSEN CUTPT
C
          CUTPT(1) = PLAPTS(1,2)
          CUTPT(2) = PLAPTS(2,2)
          CUTPT(3) = PLAPTS(3,2)
C
C CHECK THE INPT TO SEE IF THE NORMAL IS THE CORRECT SENSE
C
          VEC1(1) = INPT(1) - CUTPT(1)
          VEC1(2) = INPT(2) - CUTPT(2)
          VEC1(3) = INPT(3) - CUTPT(3)
          DOT = VEC1(1)*CUTNRM(1) + VEC1(2)*CUTNRM(2) +
     $          VEC1(3)*CUTNRM(3)
          IF(DOT .GT. 0) THEN
             CUTNRM(1) = -CUTNRM(1)
             CUTNRM(2) = -CUTNRM(2)
             CUTNRM(3) = -CUTNRM(3)
          END IF
      END IF

      RETURN
      END

max_stars_repo_name: brian-kelley/seacas

max_issues_repo_name: brian-kelley/seacas

max_forks_repo_name: brian-kelley/seacas


text:
C-------------------------------------------------------------------------
C Subroutine ELPLOT
C
C To display the points and the fitted ellipses (FITELLI)
C
C Originally from Dave Carter
C Version July 17th 1987
C-------------------------------------------------------------------------
	SUBROUTINE ELPLOT(NAMEF)
	PARAMETER (IDIM=800,IDIM1=6000)
	PARAMETER (KCUR=100)
 	REAL*8 A,B,OX,OY,PHI
	REAL*4 X(IDIM1),Y(IDIM1)
 	REAL*4 X1(IDIM,KCUR),Y1(IDIM,KCUR)
	INTEGER*4 NPTS(KCUR)
	CHARACTER NAMEF*60,TITLE*40,CHAR1*30,CHAR2*30
	CHARACTER NCHAR(KCUR)*4,PCOLOR(KCUR)*30
	CHARACTER NYN*1,PLOTDEV*32,COMMENTS*80
	include 'jlpsub:jlp_graphic_help.for'

10	FORMAT(A)
	ISAFE=0
C
C Opens input file :

C	PRINT *,' NAME OF FILE TO PLOT??'
C	READ(5,10) NAMEF
	OPEN(11,FILE=NAMEF,FORM='UNFORMATTED',
	1	STATUS='OLD',ERR=99)

C Increment :
	THINC=3.14159/195
C------------------------------------------------------------
C Reading the file :
C-------------------------------------------------------------
	K=0
C--------
C Reading the contour and storing only a subsample of the contour :

200	READ(11,END=100,ERR=999) LMAX,(X(I),Y(I),I=1,LMAX)
C	PRINT *,' LMAX,X(1)Y(1)----10',LMAX,(X(I),Y(I),I=1,10)

C Defining the subsample :
	K=K+1
	ICNT = 1
94	  IF(LMAX.LT.800) GOTO 95
	  ICNT = ICNT*2
	  LMAX = LMAX/2
	  GOTO 94
95	  DO 101 I=1,LMAX
	  X1(I,K)=X(ICNT*I)
	  Y1(I,K)=Y(ICNT*I)
101	  CONTINUE

C Close the isophote:
	LMAX=LMAX+1
	X1(LMAX,K)=X1(1,K)
	Y1(LMAX,K)=Y1(1,K)
	NPTS(K)=LMAX
	NCHAR(K)='L0'
        PCOLOR(K)='Default'

C----
C Reading the ellipse parameters and generating an ellipse :

300	READ(11,END=100,ERR=1999) A,B,PHI,OX,OY
C	PRINT *,' A,B,PHI,OX,OY',A,B,PHI,OX,OY

	K=K+1
	COSPHI=COS(PHI)
	SINPHI=SIN(PHI)
	THETA=-THINC
	  DO 20 I=1,402
	  THETA=THETA+THINC
	  XX1=A*COS(THETA)
	  YY1=B*SIN(THETA)
	  X1(I,K)=XX1*COSPHI-YY1*SINPHI+OX
	  Y1(I,K)=YY1*COSPHI+XX1*SINPHI+OY
20	  CONTINUE

	NPTS(K)=402
	NCHAR(K)='L1'
        PCOLOR(K)='Default'

C Suppression of the level if LMAX=0
	IF(LMAX.EQ.0)THEN
	  K=K-2
	ENDIF

C Return to the beginning of the loop
	GO TO 200

C K : number of curves
100	NCURVE=K
C	  PRINT *,' NCURVE',NCURVE
	  IF(NCURVE.EQ.0)THEN
 	   PRINT *,' ELPLOT/ Fatal error: NCURVE=0 !'
	   RETURN
	  ENDIF
C----------------------------------------------------------
C Displaying the curves :

	CHAR1=' '
	CHAR2=' '
	TITLE=NAMEF
	CALL CORREC_TITLE(TITLE)
	NMAX=IDIM
78	PRINT *,' OUTPUT DEVICE : (? for help):'
	READ(5,10) PLOTDEV
	IF((PLOTDEV(1:1).EQ.'?').OR.(PLOTDEV(1:1).EQ.' '))THEN
	   PRINT 3333
	   GOTO 78
	ENDIF
        COMMENTS=' '
	CALL NEWPLOT(X1,Y1,NPTS,NMAX,NCURVE,CHAR1,CHAR2,TITLE,
	1	NCHAR,PCOLOR,PLOTDEV,NAMEF,COMMENTS)
	CLOSE(11)
	RETURN
99	PRINT *,' ELPLOT/ Error opening data file'
	RETURN
999	PRINT *,' ELPLOT/ Error reading data file (contour)'
	ISAFE=ISAFE+1
	IF(ISAFE.LT.10)GO TO 200
	CLOSE(11)
	RETURN
1999	PRINT *,' ELPLOT/ Error reading data file (parameters)'
	ISAFE=ISAFE+1
	IF(ISAFE.LT.10)GO TO 300
	CLOSE(11)
	RETURN
	END
C-----------------------------------------------------------------
	SUBROUTINE CORREC_TITLE(TITLE)
	CHARACTER*40 TITLE
	DO I=1,40
	IF(TITLE(I:I).EQ.'_')TITLE(I:I)='-'
	END DO
	RETURN
	END

ext: for


text:
      subroutine VKlSt(q,m,aux,i,f)
c     subroutine for massive V spinor alla Kleiss and Stirling
C     q complex vector q(4),q(1),q(2),q(3)=E_q,qx,qy,qz
C     'aux' massless auxiliary complex vector
C     i polarization 1 or -1
C     f output spinor
      implicit none
      integer i,j
      double precision m
      double complex q(4),qt(4),aux(4),f(4),fqt(4),eta(4),den,qDaux,qsq

      if (m .eq. 0d0) then
        call uspinor0(q,-i,f)
        return
      else
        qDaux=q(4)*aux(4)-q(1)*aux(1)-q(2)*aux(2)-q(3)*aux(3)
        qsq=q(4)**2-q(1)**2-q(2)**2-q(3)**2
        qt(:)=q(:)-0.5d0*qsq/qDaux*aux(:)
        call uspinor0(aux,i,eta)
        call ubarspinor0(qt,-i,fqt)
        den=eta(1)*fqt(1)+eta(2)*fqt(2)+eta(3)*fqt(3)+eta(4)*fqt(4)
      endif

      call kslashU(q,eta,f)
      do j=1,4
      f(j)=(f(j)-eta(j)*m)/den
      enddo
      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


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

      SUBROUTINE CHKHOL (IA, L, MP, ML, MS, MR, MSC, IPOINT, COOR,
     &   IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN,
     &   ISIDE, NLPS, IFLINE, ILLIST, IREGN, NSPR, IFSIDE, ISLIST,
     &   NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB,
     &   IFHOLE, NHPR, IHLIST, LINKP, LINKL, LINKS, LINKR, LINKSC,
     &   LINKPB, LINKLB, LINKSB, RSIZE, NPREGN, NPSBC, NPNODE, MAXNP,
     &   MAXNL, MXNPER, MXRNBC, MXRSBC, X, Y, NID, LISTL, MARKED, MXNL,
     &   MAXNBC, MAXSBC, AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG,
     &   LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD, NNXK, REMESH,
     &   REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN,
     &   NOROOM, ERRCHK, ERR)
C***********************************************************************

C  CHKRGN - CHECK THAT A REGION MAY BE MESHED

C***********************************************************************

      DIMENSION IA(1)
      DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP)
      DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML), LCON(3, ML)
      DIMENSION ILBOUN(ML), ISBOUN(ML), ISIDE(MS), NLPS(MS)
      DIMENSION IFLINE(MS), ILLIST(MS*3)
      DIMENSION IREGN(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4)
      DIMENSION RSIZE (MR)
      DIMENSION NPPF(MP), IFPB(MP), LISTPB(2, MP)
      DIMENSION NLPF(ML), IFLB(ML), LISTLB(2, ML)
      DIMENSION NSPF(ML), IFSB(ML), LISTSB(2, ML)
      DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS)
      DIMENSION LINKR(2, MR), LINKSC(2, MR), LINKPB(2, MP)
      DIMENSION LINKLB(2, ML), LINKSB(2, ML)
      DIMENSION X(MAXNP), Y(MAXNP), NID(MAXNP)
      DIMENSION LISTL(MAXNL), MARKED(3, MAXNL)
      DIMENSION IFHOLE(MR), NHPR(MR), IHLIST(MR*2)

      DIMENSION IDUMMY(1)

      DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD)
      DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD)
      DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD)

      LOGICAL NOROOM, EVEN, ERR, CCW, REAL, ADDLNK, REMESH
      LOGICAL COUNT, ERRCHK

      addlnk = .false.
      COUNT = .TRUE.
      EVEN = .FALSE.
      REAL = .FALSE.

C  CHECK TO MAKE SURE CONNECTING DATA FOR THE REGION EXISTS
C  AND FILL IN ANY BLANK INTERVALS ACCORDING TO THE GIVEN SIZE
C  FOR THE REGION AND THE LINE'S LENGTH

      IF (NHPR(L) .GT. 0) THEN
         DO 100 I = IFHOLE(L), IFHOLE(L) + NHPR(L) - 1
            IPNTR1 = 0
            CALL LTSORT (MR, LINKR, IHLIST(I), IPNTR1, ADDLNK)
            IF (IPNTR1 .GT. 0) THEN
               LL = IPNTR1
               CALL DATAOK (MP, ML, MS, MR, LL, IREGN(LL), COOR, ILINE,
     &            LTYPE, NINT, LCON, NLPS, IFLINE, ILLIST, NSPR, IFSIDE,
     &            ISLIST, LINKP, LINKL, LINKS, RSIZE(LL), ERRCHK, ERR)
               IF (ERR) THEN
                  WRITE (*, 10000) IREGN(LL)
                  ADDLNK = .TRUE.
                  IMINUS = -LL
                  CALL LTSORT (MR, LINKR, IREGN(LL), IMINUS, ADDLNK)
                  ADDLNK = .FALSE.

C  CALCULATE THE PERIMETER OF THE REGION

               ELSE
                  KNBC = 0
                  KSBC = 0

                  CALL PERIM (MP, ML, MS, NSPR(LL), MAXNL, MAXNP, 1, 1,
     &               KNBC, KSBC, IREGN(LL), IPOINT, COOR, IPBOUN, ILINE,
     &               LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE,
     &               NLPS, IFLINE, ILLIST, ISLIST(IFSIDE(LL)), NPPF,
     &               IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB,
     &               LISTSB, LINKP, LINKL, LINKS, LINKPB, LINKLB,
     &               LINKSB, X, Y, NID, NPER, LISTL, NL, IDUMMY,
     &               MARKED, EVEN,  REAL, ERR, CCW, COUNT, NOROOM,
     &               AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG,
     &               LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD,
     &               NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX,
     &               IDIVIS, SIZMIN, EMAX, EMIN)
                  IF ((NPER .LE. 0) .OR. (ERR)) THEN
                     WRITE (*, 10010) IREGN(LL)
                     ADDLNK = .TRUE.

                     IMINUS = -LL
                     CALL LTSORT (MR, LINKR, IREGN(LL), IMINUS, ADDLNK)
                     ADDLNK = .FALSE.
                  ELSE

C  WHEN CHECKING THE MAXIMUMS - ADD ENOUGH FOR ONE MORE INTERVAL
C  ON THE LINE AS THIS LINE MAY BE INCREMENTED BY ONE IF THE
C  PERIMETER IS ODD

                     MAXNBC = MAX(MAXNBC, KNBC + 3 + MXRNBC)
                     MAXSBC = MAX(MAXSBC, KSBC + 3 + MXRSBC)
                     MXNL   = MAX(MXNL, NL)
                     MXNPER = MAX(MXNPER, NPER + 2)

C  MARK THE LINES AND POINTS IN THE REGION AS BEING USED

                     CALL MKUSED (MAXNL, MP, ML, LISTL, IPOINT, NINT,
     &                  LINKP, LINKL, LCON, NL)
                  ENDIF
               ENDIF
            ELSE
               WRITE (*, 10020) IREGN(LL)
               ERR = .TRUE.
            ENDIF
  100    CONTINUE
      END IF

      RETURN

10000 FORMAT (' ** ERROR - DATA PROBLEMS FOR HOLE REGION:', I5, ' **')
10010 FORMAT (' ** ERROR - PERIMETER GENERATION ERRORS FOR HOLE REGION:'
     &   , I5, ' **')
10020 FORMAT (' ** ERROR - HOLE REGION', I5, ' DOES NOT EXIST **')
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
module module_status

use netcdf

integer                      :: STATUS_ERROR = 0
character(len=180)           :: STATUS_TEXT  = ""

contains
! ...
! ====================================================================
! ====================================================================
! ...
subroutine check_status()

if (STATUS_ERROR.eq.0) return

write(0,*) 'ERROR: '//trim(STATUS_TEXT)
stop -1

end subroutine check_status
! ....
! ====================================================================
! ...
subroutine cdf_error()

if (STATUS_ERROR.ne.NF90_NOERR) then
  STATUS_TEXT = trim(NF90_STRERROR(STATUS_ERROR))
  call check_status()
endif

end subroutine cdf_error
! ...
! ====================================================================
! ...
end module module_status

max_stars_repo_name: quimbp/cosmo

max_issues_repo_name: quimbp/cosmo

max_forks_repo_name: quimbp/cosmo


text:
! not done yet

! dummy
       function bulgefixeddens(r,z) result(x)
        real r,z,x
        x=0
       end function

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
module a_11_54
  integer longName
end module a_11_54

module b_11_54
  integer longName
end module b_11_54

module a1_11_54
  use a_11_54, only: s => longName
  private :: foo
  public :: a1Foo
  interface a1Foo
     module procedure foo
  end interface
contains
  subroutine foo()
    s=s+1
  end subroutine foo
end module a1_11_54

module b1_11_54
  use b_11_54, only: s => longName
  private :: foo
  public :: b1Foo
  interface b1Foo
     module procedure foo
  end interface
contains
  subroutine foo()
    s=s+1
  end subroutine foo
end module b1_11_54

program multRename
  use a_11_54, only: aL=>longName
  use b_11_54, only: bL=>longName
  use a1_11_54
  use b1_11_54
  aL=1
  bL=2
  call a1Foo()
  call b1Foo()
  if (aL==2 .and. bL == 3) then
     print *,'OK'
  else
     print *,'FAILED'
  endif
end program multRename

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      SUBROUTINE RENAME
*
*
*       Renaming of list arrays.
*       ------------------------
*
      INCLUDE 'common6.h'
*
*
*       Old & new names are shown explicitly for three different cases.
*
*       Standard sequence     ICOMP = 2*NPAIRS-1     ICOMP = 2*NPAIRS
*       -------------------------------------------------------------------
*       2*NPAIRS-1 ICOMP       2*NPAIRS-1 ICOMP       2*NPAIRS-1 JCOMP
*       2*NPAIRS   JCOMP       ICOMP      2*NPAIRS-1  ICOMP      2*NPAIRS-1
*       ICOMP      2*NPAIRS-1  2*NPAIRS   JCOMP       2*NPAIRS   2*NPAIRS-1
*       JCOMP      2*NPAIRS    JCOMP      2*NPAIRS    JCOMP      2*NPAIRS
*       -------------------------------------------------------------------
*
*       Form the sequential names of exchanged & regularized bodies.
      ILIST(1) = 2*NPAIRS - 1
      ILIST(2) = 2*NPAIRS
      ILIST(3) = ICOMP
      ILIST(4) = JCOMP
*       Save the corresponding new names for the renaming procedure.
      ILIST(5) = ILIST(3)
      ILIST(6) = ILIST(4)
      ILIST(7) = ILIST(1)
      ILIST(8) = ILIST(2)
*       Ensure consecutive search list and modify renaming list accordingly.
      IF (ICOMP.LE.ILIST(2)) THEN
          ILIST(3) = ILIST(2)
          ILIST(2) = ICOMP
*       Note that all the new names are affected by the rearrangement.
          ILIST(5) = ILIST(2)
          ILIST(6) = ILIST(1)
          ILIST(7) = ILIST(4)
          ILIST(8) = ILIST(3)
          IF (ICOMP.NE.ILIST(1)) THEN
*       First single particle is exchanged twice if ICOMP = 2*NPAIRS.
              ILIST(5) = JCOMP
              ILIST(7) = ILIST(1)
*       New name of 2*NPAIRS is not really needed because of duplicity.
          END IF
      END IF
*
*       Rename neighbour lists with exchanged or regularized components.
      DO 40 J = 1,NTOT-1
*       Skip modification if first neighbour comes after second component.
          IF (LIST(2,J).GT.JCOMP) GO TO 40
*       No special precaution needed for case of no neighbours.
          NNB = LIST(1,J)
          NNB1 = 0
          NIJ = 0
*
*       See whether any neighbours need to be renamed.
          K1 = 1
          DO 25 L = 2,NNB+1
              IF (LIST(L,J).GT.JCOMP) GO TO 30
*       Start search loop above last identified value (bug fix 10/07).
              DO 20 K = K1,4
                  IF (LIST(L,J).EQ.ILIST(K)) THEN
                      K1 = K + 1
                      NNB1 = NNB1 + 1
*       Save corresponding list location for the modification loop.
                      JLIST(NNB1) = K
                      JLIST(NNB1+4) = L
*       Count number of identified KS components.
                      IF (ILIST(K).EQ.ICOMP.OR.ILIST(K).EQ.JCOMP)
     &                                                     NIJ = NIJ + 1
*       Advance neighbour list after each identification (note duplicity).
                      GO TO 25
                  END IF
   20         CONTINUE
   25     CONTINUE
*
*       Skip modification if no neighbours need to be renamed.
   30     IF (NNB1.EQ.0) GO TO 40
*
*       Include c.m. renaming procedure if both components are neighbours.
          DO 38 K = 1,NNB1
              KTIME = JLIST(K)
*       Indicator for identified members of search list.
              INEW = ILIST(KTIME+4)
*       Replace identified components (or single perturber) by c.m.
              IF (INEW.LT.IFIRST) THEN
                  IF (NIJ.EQ.2.OR.J.LT.IFIRST - 3) INEW = NTOT
              END IF
*       Start with the saved list index (may differ by one either way).
              LS = JLIST(K+4)
*       See if index needs adjusting after previous modification.
              IF (LIST(LS,J).LT.ILIST(KTIME)) LS = LS + 1
              IF (LIST(LS,J).GT.ILIST(KTIME)) LS = LS - 1
*
*       Move list members up or down unless new name is identical to old.
              IF (LS.LE.0) LS = 2
              LL = LS
              IF (INEW.LT.ILIST(KTIME)) THEN
*       Move list members down by one until location for new name is vacated.
                  DO 32 L = LL,3,-1
                      IF (LIST(L-1,J).GT.INEW) THEN
                          LIST(L,J) = LIST(L-1,J)
                          LS = L - 1
                      ELSE
                          GO TO 36
                      END IF
   32             CONTINUE
              ELSE IF (INEW.GT.ILIST(KTIME)) THEN
*       Move list members up by one until sequential location is reached.
                  DO 34 L = LL,NNB
                      IF (LIST(L+1,J).LT.INEW) THEN
                          LIST(L,J) = LIST(L+1,J)
                          LS = L + 1
                      ELSE
                          GO TO 36
                      END IF
   34             CONTINUE
              END IF
*       Set renamed neighbour in sequential location.
   36         LIST(LS,J) = INEW
   38     CONTINUE
*
*       Reduce membership by one if c.m. set in last two locations.
          IF (NIJ.EQ.2) LIST(1,J) = NNB - 1
   40 CONTINUE
*
*       Update the list of recently regularized particles.
   41 NNB = LISTR(1)
      DO 44 L = 2,NNB+1
*       First see whether either component has been regularized before.
          IF (LISTR(L).EQ.ICOMP.OR.LISTR(L).EQ.JCOMP) THEN
*       Remove corresponding pair even if only one component is present.
              J = 2*KVEC(L-1)
*       Move up the subsequent pairs and reduce membership by two.
              DO 42 K = J,NNB-1
                  LISTR(K) = LISTR(K+2)
   42         CONTINUE
              LISTR(1) = LISTR(1) - 2
*       Make a new search otherwise LISTR -> -2 if NNB = 2.
              GO TO 41
          END IF
   44 CONTINUE
*
*       Rename exchanged components if present in the list.
      DO 48 KCOMP = 1,2
          DO 46 L = 2,NNB+1
              IF (LISTR(L).EQ.2*NPAIRS - 2 + KCOMP) THEN
                  IF (KCOMP.EQ.1) LISTR(L) = ICOMP
                  IF (KCOMP.EQ.2) LISTR(L) = JCOMP
              END IF
   46     CONTINUE
   48 CONTINUE
*
*       Update the list of high velocity particles.
      IF (LISTV(1).EQ.0) GO TO 70
      NNB = LISTV(1)
      L = 1
   50 L = L + 1
*       Check for removal of regularized component.
      IF (LISTV(L).EQ.ICOMP.OR.LISTV(L).EQ.JCOMP) THEN
          DO 52 K = L,NNB
              LISTV(K) = LISTV(K+1)
   52     CONTINUE
          LISTV(1) = LISTV(1) - 1
          NNB = NNB - 1
*       Consider the same location again.
          L = L - 1
      END IF
      IF (L.LE.NNB) GO TO 50
*
*       Rename exchanged components.
      DO 58 KCOMP = 1,2
          DO 56 L = 2,NNB+1
              IF (LISTV(L).EQ.2*NPAIRS - 2 + KCOMP) THEN
                  IF (KCOMP.EQ.1) LISTV(L) = ICOMP
                  IF (KCOMP.EQ.2) LISTV(L) = JCOMP
              END IF
   56     CONTINUE
   58 CONTINUE
*
*       Remove any fast particles which have slowed down or are outside 2<R>.
      L = 1
   60 L = L + 1
      IF (LISTV(1).EQ.0) GO TO 70
      J = LISTV(L)
      A0 = XDOT(1,J)**2 + XDOT(2,J)**2 + XDOT(3,J)**2
      A2 = (X(1,J) - RDENS(1))**2 + (X(2,J) - RDENS(2))**2 +
     &                              (X(3,J) - RDENS(3))**2
      IF (A0.LT.16.0*ECLOSE.OR.A2.GT.4.0*RSCALE**2) THEN
          DO 65 K = L,NNB
              LISTV(K) = LISTV(K+1)
   65     CONTINUE
          LISTV(1) = LISTV(1) - 1
          NNB = NNB - 1
*       Consider the same location again.
          L = L - 1
      END IF
      IF (L.LE.NNB) GO TO 60
*
   70 RETURN
*
      END


text:
        !COMPILER-GENERATED INTERFACE MODULE: Thu Apr 13 17:24:33 2017
        MODULE GEIDERPHY_SIZE__genmod
          INTERFACE
            SUBROUTINE GEIDERPHY_SIZE(PMU,NO3,TC,PAR_,THETA,MUNET,SI,   &
     &LNO3)
              REAL(KIND=8), INTENT(IN) :: PMU
              REAL(KIND=8), INTENT(IN) :: NO3
              REAL(KIND=8), INTENT(IN) :: TC
              REAL(KIND=8), INTENT(IN) :: PAR_
              REAL(KIND=8), INTENT(IN) :: THETA
              REAL(KIND=8), INTENT(OUT) :: MUNET
              REAL(KIND=8), INTENT(OUT) :: SI
              REAL(KIND=8), INTENT(OUT) :: LNO3
            END SUBROUTINE GEIDERPHY_SIZE
          END INTERFACE
        END MODULE GEIDERPHY_SIZE__genmod

max_stars_repo_name: BingzhangChen/NPZDFeCONT

max_issues_repo_name: BingzhangChen/NPZDFeCONT

max_forks_repo_name: BingzhangChen/NPZDFeCONT


text:
      SUBROUTINE spp2( c, ibuf )
!     SPP simulates the Versatec Simultaneous Print/Plot mode by ORing a
!  character arry into a set of raster lines.
!     The way this program works is that it has only numeric fonts.  When
!  SPP gets a non blank annotation (c), it moves 16 lines of digitized
!  font into a storage buffer.  Each call to SPP then ORs the top line of
!  the storage buffer into the users ibuf array.  After the OR, the storage
!  array is moved up one raster so that the next call to SPP gets in essence
!  the next line of the character.  Thus, it takes 16 calls to SPP to flush
!  a whole character.  A new non blank character in c before the 16th call
!  will reset the SPP OR array.
!     This version of SPP assumes c is 8 characters big.
!
!  Copyright (C) 1987 by Paul Henkart, Seismic Reflection Processors, San Diego
!  ALL RIGHTS RESERVED
!
!   mod 8 Aug 1991 by pch - add minus
! mod 22 May 92 - add color
! mod 8 feb 93 - add rgb (rgb=0 means CYM, where white and black are
!                opposite to RGB.  ie in CYM white is no planes and
!                black is all planes - sorta like a B&W plot.
! mod 10 Jul 02 - Add reverse direction annotation by using kfonts and lfonts,
!                which is upsidedown and backwards.
! mod 29 Jan 03 - nibs 75 annotation on PC was bad
! mod 13 Jan 04 - Change common defs and colors from 8 to 9
! mod 10 Oct 06 - Change ltr font (kfonts) for 1 and 3,
!  mod 14 Aug 07 - g95 IAND args must be same size.
!
      INTEGER*2 ibuf(1111),itemp,itemp1, itemp2, i255
      INTEGER*2 ifonts(160), jfonts(80), minus(16), kfonts(160),
     *          lfonts(80)
      CHARACTER*8 c, cc
      COMMON /versat/ nibs, rnibs
      COMMON /edits/ ierror, iwarn, irun, now, icompt
      INTEGER*2 RSHIFT, LSHIFT
      INTEGER*2 iorbuf(8,16),jorbuf(8,8)                                ! this holds 8 rasterized characters
      COMMON /colors/ defs(9), colors(9), ncolors, bcolor, rgb
      INTEGER colors, bcolor, rgb
      COMMON /PLOT/munit,nlists,ftag,taginc,fspace,nspace,spacei,idir,
     &    irecsp, lunhead, nraster
      LOGICAL first
      SAVE
      DATA iorbuf/128*0/, jorbuf/64*0/, first/.TRUE./, i255/255/
      DATA minus/8*0,1023,7*0/
      DATA ifonts/ 0,1008,1032,10*2052,1032,1008,0,                     ! zero
     1 0,32,96,160,288,544,32,32,32,32,32,32,32,32,2044,0,              ! one
     2 0,4064,16,4*8,16,32,64,128,256,512,1024,4092,0,                  ! two
     3 0,4080,8,8,8,8,8,1008,8,8,8,8,8,8,4080,0,                        ! three
     4 0,32,64,128,256,512,1024,2080,4128,8176,5*32,0,                  ! four
     5 0,4092,5*2048,4080,8,4*4,8,4080,0,                               ! five
     6 0,508,512,1024,4*2048,4092,5*2052,4092,0,                        ! six
     7 0,4092,4,8,16,32,64,128,256,256,512,512,2*1024,2048,0,           ! seven
     8 0,2040,5*2052,2040,6*2052,2040,0,                                ! eight
     9 0,1008,1032,3*2052,1036,1012,7*4,0 /                             ! nine
      DATA jfonts/28,34,34,34,34,34,28,0,                               ! zero
     1 8,24,40,8,8,8,24,0,                                              ! one
     2 28,2,2,4,8,16,62,0,                                              ! two
     3 60,2,2,28,2,2,60,0,                                              ! three
     4 4,12,20,36,126,4,4,0,                                            ! four
     5 62,32,32,60,2,2,60,0,                                            ! five
     6 28,32,32,62,34,34,62,0,                                          ! six
     7 62,2,4,8,16,32,32,0,                                             ! seven
     8 28,34,34,28,34,34,28,0,                                          ! eight
     9 28,34,34,28,2,2,2,0/                                             ! nine
      DATA kfonts/0,4032,4128,10*8208,4128,4032,0,                      ! zero
!     1 0,16352,8*1024,64,1152,1280,1536,1024,0,                         ! one
     1 0,16352,8*1024,1088,1152,1280,1536,1024,0,                         ! one
     2 0,16368,32,64,128,256,512,1024,2048,4*4096,2048,2032,0,          ! two
!     3 0,4080,6*4096,-16448,5*4096,4080,0,                              ! three
     3 0,4080,6*4096,4032,5*4096,4080,0,                                ! three
     4 0,5*1024,4088,1032,1040,32,64,128,256,512,1024,0,                ! four
     5 0,4080,4096,4*8192,4096,4080,5*16,16368,0,                       ! five
     6 0,16368,5*8208,16368,4*16,32,64,16256,0,                         ! six
     7 0,16,2*32,2*64,128,128,256,512,1024,2048,4096,8192,16368,0,      ! seven
     8 0,16368,6*8208,8160,5*8208,12256,0,                              ! eight
     9 0,7*4096,12224,12320,3*8208,4128,4032,0/
      DATA lfonts/0,14336,5*17408,14336,
     1 0,6144,3*4096, 5120, 6144, 4096,
     2 0, 31744, 2048, 4096, 8192, 2*16384, 14336,
     3 0, 15360, 2*16384, 14336, 2*16384, 15360,
     4 0, 2*8192, 32256, 9216, 6144, 12288, 8192,
     5 0, 15360, 2*16384, 15360, 2*1024, 31744,
     6 0, 31744, 2*17408, 31744, 2*1024, 14336,
     7 0, 2*1024, 2048, 4096, 8192, 16384, 31744,
     8 0, 14336, 2*17408, 14336, 2*17408, 14336,
     9 0, 3*16384, 14336, 2*17408, 14336/
       IF( first ) THEN
          first = .FALSE.
          IF( idir .LT. 0 ) THEN
              DO i = 1, 160
                 ifonts(i) = kfonts(i)
              ENDDO
              DO i = 1, 80
                 jfonts(i) = lfonts(i)
              ENDDO
          ENDIF
          IF( icompt .EQ. 2 .OR. icompt .EQ. 4 ) THEN
              CALL swap16( ifonts, 160 )
              CALL swap16( jfonts, 80 )
              CALL swap16( minus, 16 )
          ENDIF
          IF( ncolors .NE. 0 .AND. rgb .EQ. 1) THEN
              DO i = 1, 160
   10            ifonts(i) = NOT( ifonts(i) )
              ENDDO
              DO i = 1, 80
   11            jfonts(i) = NOT( jfonts(i) )
              ENDDO
              DO 13 i = 1, 8
                 DO 12 j = 1, 8
                    jorbuf(i,j) = -1
   12            CONTINUE
   13         CONTINUE
              DO i = 1, 16
                 DO j = 1, 8
   15               iorbuf(j,i) = -1
                 ENDDO
   20            minus(i) = NOT( minus(i) )
              ENDDO
          ENDIF
      ENDIF
      cc(1:8) = c(1:8)
      IF( cc(1:8) .NE. ' ') THEN
          IF( idir .LT. 0 ) THEN
              DO i = 1, 8
                 cc(i:i) = c(9-i:9-i)
              ENDDO
          ENDIF
          DO 190 i=1,8                                                  ! do each character
              IF( cc(i:i) .NE. ' ') THEN
!                                   ICHAR('0') is 48 (decimal or 30 hex)
                  j = (ICHAR(cc(i:i))-48)*16                             ! get the index of the char
                  IF( j .LT. 0 .OR. j .GT. 144 ) GOTO 120
                  IF( rnibs .GT. 100. ) THEN
                      DO 110, k=1,16                                    ! store each character raster line
                         iorbuf(i,k) = ifonts(j+k)
  110                 CONTINUE
                  ELSE
                      j = j / 2
                      DO 115, k=1,8                                     ! store each character raster line
                         jorbuf(i,k) = jfonts(j+k)
  115                CONTINUE
                  ENDIF
               ENDIF
  120          CONTINUE
               IF( cc(i:i) .EQ. '-' ) THEN
                   IF( rnibs .GT. 100. ) THEN
                       DO 140 k = 1, 16
                          iorbuf(i,k) = minus(k)
  140                  CONTINUE
                   ELSE
                       DO 150 k = 1, 8
                          jorbuf(i,k) = minus(k*2-1)
  150                  CONTINUE
                   ENDIF
               ENDIF
  190     CONTINUE
      ENDIF
      IF( rnibs .GT. 100. ) THEN
          DO 200 i=1,8
!             ibuf(i) = IOR( ibuf(i), iorbuf(i,1) )                       ! only 1 raster line!
             ibuf(i) = iorbuf(i,1)
  200     CONTINUE
      ELSE
          j = 1
          DO 300 i = 1, 4
             IF( idir .GE. 0 ) THEN
                 IF( icompt .NE. 2 .AND. icompt .NE. 4 ) THEN
                     itemp = LSHIFT( jorbuf(j,1), 8 )
                     j = j + 1
                     itemp2 = IAND(jorbuf(j,1),i255)
                     itemp1 = IOR( itemp, itemp2 )
                 ELSE
                     itemp = RSHIFT(jorbuf(j,1),8)
                     j = j + 1
                     itemp1 = IOR( itemp, jorbuf(j,1))
                 ENDIF
             ELSE
                 IF( icompt .NE. 2 .AND. icompt .NE. 4 ) THEN
                     itemp = jorbuf(j,1)
                     j = j + 1
                     itemp1 = IOR( itemp, RSHIFT(jorbuf(j,1),8) )
                 ELSE
                     itemp = jorbuf(j,1)
                     j = j + 1
                     itemp1 = IOR( itemp, LSHIFT(jorbuf(j,1),8))
                 ENDIF
             ENDIF
!             ibuf(i) = IOR( ibuf(i), itemp1 )
             ibuf(i) = itemp1
             j = j + 1
  300     CONTINUE
      ENDIF

      IF( rnibs .GT. 100. ) THEN
          DO 320 j=1,15                                                 ! move the or buffer up 1 raster line
             DO 310 i=1,8                                               ! do each character
                 iorbuf(i,j) = iorbuf(i,j+1)
  310        CONTINUE
  320     CONTINUE
      ELSE
          DO 340 j = 1, 7
             DO 330 i = 1, 8
                jorbuf(i,j) = jorbuf(i,j+1)
  330        CONTINUE
  340     CONTINUE
      ENDIF

      DO 400 i=1,8                                                      ! zero out the next rastered annotation
          IF( ncolors .NE. 0 .AND. rgb .EQ. 1 ) THEN
              iorbuf(i,16) = -1
              jorbuf(i,8) = -1
          ELSE
              iorbuf(i,16)=0
              jorbuf(i,8)=0
          ENDIF
  400 CONTINUE

      RETURN
      END


text:
Elle Segal is a candidate for the ASUCD Senate with LEAD L.E.A.D. running in Winter 2009 ASUCD election.

 Candidate Statement and Activities

Hey there! My name is Elle Segal and I want you to vote for me for ASUCD Senate in the Winter 2009 election on February 18th through 20th. I’m really excited to help serve you, the students of UC Davis. I greatly appreciate your support!

ELECTIONS ARE FEBRUARY 18th20th

About Me: Hey guys! My name is Arielle Segal, but everyone calls me Elle. I am a second year psychology and anthropology double major at UC Davis. I was born and raised on the east coast and moved to Irvine when I was a freshman in high school. One of the ways I made friends and got involved in high school was various clubs on campus, ranging from Model United Nations, to Environmental Club. My involvement in high school lead me to accomplish many things I am proud of, such as cofounding walk to school day at my high school, which this past year went district wide! My experiences as a freshman at Davis in ASUCD Lobbycorp,and Greek life continued to build on my previous experiences and leadership skills.

Experience:
Internal Director of ASUCD Lobbycorp
Public Relations Director of Panhellenic
Member of Greek Conduct Board
Member of City of Davis Student Liaison Commission
Member of Kappa Alpha Theta
Employee/Student Representative for wiki:irvine City of Irvine

SENATE GOALS:

BIKE SAFETY
I want to coordinate with bike shops in Davis to provide discounted bike lights to freshman upon checking into the dorms. This will encourage the use of bike light for students from the beginning of their college experience here at Davis. Coupons will be given to students, which will encourage them to go to the store and see what other options are available like rear lights and baskets etc.  This year I have noticed more police officers ticketing bikers and this would encourage students to follow the law, and thus prevent them from getting a ticket.  I would also advise students to remove bike lights from their bikes when not in use which would prevent theft because many freshman purchase bike lights only to have them stolen and never replaced.

ARC IMPROVEMENT
I want to work with the ARC and the computer labs on campus to make the computer center at the ARC both more reliable and publicized. Currently, many of the computers are slow and there is no printer and I want to fix that and make the ARC an alternative to the MU computer lab on campus. Also, with the COHO renovation beginning soon, I want to make the ARC the new place to hang out on campus. Starbucks will be opening there soon and there are study rooms available. The ARC is the activities and recreation center and it should provide many different activities for students.  There are many simple ways to improve the ARC.  For example, instead of paper towels and spray to sanitize the machines after use, getting clorox wipes put in the gyms to improve sanitation efforts.

ADVOCACY
As mentioned earlier, I am currently a director of ASUCD Lobbycorp and want to use my experience lobbying in the capital to encourage other groups to take advantage of our close distance to the capital. I will work to continue to advocate for students in the capital and educate students on tuition increases and cuts in funding on campus. Lobbycorp should hold training sessions for various groups on campus through the outreach assembly, so that groups can learn the necessary skills to advocate for their own interests at the capital.  There is such a diverse group of students and organizations present on campus and all of them have unique issues that need to be addressed.  In such pressing times, with higher student fees, and dramatic budget cuts, students need to feel able to address legislators that distribute funds and lobbycorp can help them do that.

SANITATION
I want to add hand sanitizers to many of the popular eateries, and hang out spots on campus such as the coffee house, silo and ARC.

RECYCLING
As some of you may know, as an individual you are able to turn in your recyclables to the recycling center and receive money. I want to investigate the recycling process on our campus and see if students are benefiting from recycling and if we as students could possibly reap the benefits of money made off recycling.

I would love to earn your vote for senate! Please message me or write on the group wall because I want to include YOUR ideas as students in my platform and campaign. Thanks and I look forward to working with all of you!

20090124 16:30:43 nbsp Impressive resume, unfortunately her platform is not on par.

For example:
Member of City of Davis Student Liaison Commission

The only DavisUCD platform issue being proposed is a bike coupon program. I think there are a lot of better ideas than bike coupons.

Often it is the case that we chose senators not via their platforms but for the qualities of the candidate. She certainly has a lot of good qualities and the diversity of someone raised in the East Coast can only benefit the senate.  Users/GregWebb

20090125 01:13:28 nbsp Well Greg she has a wealth of experience and a particular skill set, as youve said in regards to her resume. Youre right, her platform only has one UCDDavis issue, but her campaign platform does mention a lot about advocacy at the capital. She has the record and experience to advocate and shes focusing on budget cuts, an issue that we need all hands on deck to come out OK in this economy. Greg, youre talking a lot about what she isnt advocating for and overlooking what she plans to do. Users/JackZwald
  I agree, I should have made a proper review of all of her qualifications. To elaborate, her position in a city commission was most impressive to me and Im slightly disappointed that she has a lack of cityuniversity proposals...perhaps they will come late though. Advocacy is very important, and to be quite frank with you Jack...LEAD candidates are almost always better in advocacy issues. I guess my priorities are a little different. GregWebb


text:
module siter

use, intrinsic :: iso_fortran_env, only : dp=>real64,i64=>int64, stderr=>error_unit
use perf, only: sysclock2ms
Implicit None
integer, parameter :: wp=dp

contains

Real(dp) function simple_iter(N,Nrun) result(t)

integer,Intent(in) :: N,Nrun

integer :: j,i
integer(i64) :: tic,toc,tmin
real(wp) :: A(N)
! volatile tells compiler that value is unpredictable, don't unroll, etc.
real(wp), volatile :: x

tmin = huge(0_i64)

Do j = 1, Nrun
  call random_number(A)
  call system_clock(tic)
  x = 0._wp
  Do i = 1, N
    x = 0.5_wp*x + modulo(A(i), 10._wp)
  End Do
  call system_clock(toc)
  if (toc-tic<tmin) tmin=toc-tic
End Do

t = sysclock2ms(tmin) / 1000

End Function simple_iter

end module siter

program s

use siter, only: simple_iter, dp

implicit none

integer :: N=100000, Nrun=10, argc
character(16) :: argv

real(dp) :: t

call random_init(.false.,.false.)

argc = command_argument_count()
if (argc>0) then
  call get_command_argument(1,argv)
  read(argv,*) N
endif

if (argc>1) then
  call get_command_argument(2,argv)
  read(argv,*) Nrun
endif

t = simple_iter(N, Nrun)
print '(A,ES12.4,A)', 'Iteration: ',t,' sec.'

end program

max_stars_repo_name: scienceopen/numba-examples

max_issues_repo_name: scienceopen/numba-examples

max_forks_repo_name: scienceopen/numba-examples


text:
! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program mainWGF
    use meshread_mod
    use linalg_mod
    use WGFM_matrices
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh

    complex(8), allocatable :: ZMat(:, :)       ! WGFM matrix
    complex(8), allocatable :: eigen_array(:)   ! list of eigenvalues
    integer :: n_eigen    ! number of eigenvalues

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]
    real(8), parameter :: k0 = 2*PI          ! free-space wavenumber [1/m]

    real(8), parameter :: ep1_r = 4d0         ! upper half-space relative permittivity
    real(8), parameter :: ep2_r = 1d0         ! lower half-space relative permittivity
    real(8), parameter :: ep1 = ep0*ep1_r     ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0           ! upper half-space permeability [H/m]
    real(8), parameter :: ep2 = ep0*ep2_r     ! lower half-space permittivity [F/m]
    real(8), parameter :: mu2 = mu0           ! lower half-space permeability [H/m]

    real(8), parameter :: w = k0 / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]

    character(len=150), parameter ::  &
        file_msh = '/home/rodrigo/Dropbox/Rodrigo-Carlos/Meshes/dipoleMeshes/planeA6h0312.msh'
    character(len=150), parameter :: file_eig = 'results/eig312_e41.txt'
    character(len=150), parameter :: file_eig_pre = 'results/eig_pre312_e41.txt'
    real(8), parameter :: win_radius = 6d0      ! Window radius
    real(8), parameter :: win_cparam = 0.7d0    ! Window 'c' parameter

    !************************************************************************************
    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Set window type and size
    call set_circ_window(win_radius, win_cparam)

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute WGFM matrix
    if (id == 0) print *, "WGFM matrix, ", 'nEdges: ', msh%nbEdg
    call genWGFMMat(msh, w, k1, k2, ep1, ep2, mu1, mu2, ZMat)
    if (id == 0) print *, "done"

    ! MPI is no longer needed
    call MPI_Finalize(ierr)

    if (id == 0) then
        ! Example
        !allocate(ZMat(3, 3))
        !ZMat = reshape([1d0, 3d0, 2d0, 2d0, 2d0, 1d0, 3d0, 1d0, 3d0], [3, 3])

        n_eigen = size(ZMat, 1)
        allocate(eigen_array(n_eigen))

        ! Compute eigenvalues
        print *, "eigenvalues.."
        call eig(eigen_array, ZMat, n_eigen)
        print *, "done"

        ! Save data
        call save_eigenvalues(eigen_array, file_eig)

        ! Compute eigenvalues for the preconditioned system
        print *, "(preconditioned) eigenvalues.."
        call apply_diag_precond(ZMat)
        call eig(eigen_array, ZMat, n_eigen)
        print *, "done"

        ! Save data
        call save_eigenvalues(eigen_array, file_eig_pre)
    end if

contains
    subroutine save_eigenvalues(eigen_array, filename)
        complex(8), intent(in) :: eigen_array(:)
        character(len=*), intent(in) :: filename
        integer, parameter :: file_id = 1
        integer :: n

        ! Print to file. Format:
        ! real(eig(1)), imag(eig(1))
        ! real(eig(2)), imag(eig(2))
        ! etc
        open(unit=file_id, file=filename, status="REPLACE", action="WRITE")
        do n = 1, size(eigen_array)
            write(file_id, *) dreal(eigen_array(n)), dimag(eigen_array(n))
        end do
        close(file_id)
    end subroutine save_eigenvalues

    subroutine apply_diag_precond(matrix)
        complex(8), intent(inout) :: matrix(:, :)
        integer :: i
        do i = 1, size(matrix, 1)
            matrix(i,:) = matrix(i,:) / matrix(i,i)
        end do
    end subroutine apply_diag_precond
end program

max_stars_repo_name: Riarrieta/WindowedGreenFunctionMethod

max_issues_repo_name: Riarrieta/WindowedGreenFunctionMethod

max_forks_repo_name: Riarrieta/WindowedGreenFunctionMethod


text:
*dk volume_qud
      subroutine volume_qud(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
     *                      volqud)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A QUD-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME OF THE QUD IS DETERMINED
C            BY SUBDIVIDING IT INTO 4 TRIANGULAR ELEMENTS
C            USING THE MIDPOINT
C            AND THEN SUMMING THE VOLUME OF THE TRIANGLES.
C
C            compare volume_qud_alt_lg below
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC QUD.
C
C
C          4- - - -3    Edge 1: 1 2
C          |       |         2: 2 3
C          |       |         3: 3 4
C          1- - - -2         4: 4 1
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x4,y4,z4) - THE COORDINATES OF THE QUD.
C
C     OUTPUT ARGUMENTS -
C
C        volqud - THE VOLUME OF THE QUD.
C
C     CHANGE HISTORY -
C
C        $Log: volume_qud.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.4   Tue Oct 19 15:13:20 1999   jtg
CPVCS    fixed form of inv3x3 call
CPVCS
CPVCS       Rev 1.3   Tue Oct 19 13:16:54 1999   jtg
CPVCS    alternate way of caluculating volume using "minimum area
CPVCS    point" (instead of midpoint) added.
CPVCS
CPVCS       Rev 1.2   Mon Apr 14 17:05:40 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.1   Mon Nov 11 20:55:52 1996   het
CPVCS    Remove the absolute value for volume.
CPVCS
CPVCS       Rev 1.0   Mon Jul 29 15:42:48 1996   dcg
CPVCS    Initial revision.
C
C
C#######################################################################
C
      implicit real*8 (a-h,o-z)
C
C#######################################################################
C
C
C     ..................................................................
C     FIND THE MEDIAN POINT FOR EACH OF THE SIX FACES AND THE HEX.
C
      x1234=(x1+x2+x3+x4)/4.0d+00
      y1234=(y1+y2+y3+y4)/4.0d+00
      z1234=(z1+z2+z3+z4)/4.0d+00

      !local_debug=0
      !if (local_debug.gt.0) then
      !  write(*,'(a,3f12.8)') 'using mid ',x1234,y1234,z1234
      !endif
C
C
C     ..................................................................
C     FIND THE VOLUME OF THE 4-TRI QUD.
C
      call volume_tri(x1234,y1234,z1234,
     *                x1,y1,z1,
     *                x2,y2,z2,
     *                voltri1)
      call volume_tri(x1234,y1234,z1234,
     *                x2,y2,z2,
     *                x3,y3,z3,
     *                voltri2)
      call volume_tri(x1234,y1234,z1234,
     *                x3,y3,z3,
     *                x4,y4,z4,
     *                voltri3)
      call volume_tri(x1234,y1234,z1234,
     *                x4,y4,z4,
     *                x1,y1,z1,
     *                voltri4)
C
C
C     ..................................................................
C     SUM THE 4 TRI VOLUMES TO THE VOLUME OF THE QUD.
C
      volqud=voltri1+voltri2+voltri3+voltri4
C
      return
      end
C#######################################################################
C=======================================================================
C#######################################################################
*dk volume_qud_alt
      subroutine volume_qud_alt_lg(x1,y1,z1,x2,y2,z2
     *                      ,x3,y3,z3,x4,y4,z4,volqud
     *                      ,x1234,y1234,z1234)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A QUD-ELEMENT DEFINDED BY
C            4 COORDINATE NODES. THE VOLUME OF THE QUD IS DETERMINED
C            BY SUBDIVIDING IT INTO 4 TRIANGULAR ELEMENTS
C            USING THE POINT WHICH MINIMIZES THE SUM OF THE AREAS
C            AND THEN SUMMING THE VOLUME OF THE TRIANGLES.
C
C            structure and arguments same as above
C            except call also returns "min-area-point" (x1234,y1234,z1234)
C
C#######################################################################
C
      implicit none
      real*8 x1,y1,z1,x2,y2,z2 ,x3,y3,z3,x4,y4,z4,volqud
     *      ,x1234,y1234,z1234

      real*8 mat(3,3),vec(3),d(3,4),s(3,4),dd(4),ds(4),ddd
     *      ,voltri
      integer i,j,local_debug,iflag
C
C#######################################################################
C
C     ..................................................................
C     FIND THE POINT WHICH MINIMIZES THE SUM OF THE AREAS
C

      d(1,1)=x2-x1
      d(2,1)=y2-y1
      d(3,1)=z2-z1
      d(1,2)=x3-x2
      d(2,2)=y3-y2
      d(3,2)=z3-z2
      d(1,3)=x4-x3
      d(2,3)=y4-y3
      d(3,3)=z4-z3
      d(1,4)=x1-x4
      d(2,4)=y1-y4
      d(3,4)=z1-z4

      s(1,1)=x2+x1
      s(2,1)=y2+y1
      s(3,1)=z2+z1
      s(1,2)=x3+x2
      s(2,2)=y3+y2
      s(3,2)=z3+z2
      s(1,3)=x4+x3
      s(2,3)=y4+y3
      s(3,3)=z4+z3
      s(1,4)=x1+x4
      s(2,4)=y1+y4
      s(3,4)=z1+z4

      ddd=0.0d+0
      do j=1,4
         dd(j)=0.0d+0
         ds(j)=0.0d+0
         do i=1,3
            dd(j)=dd(j)+d(i,j)*d(i,j)
            ds(j)=ds(j)+d(i,j)*s(i,j)
         enddo
         ddd=ddd+dd(j)
      enddo

      do i=1,3
         vec(i)=d(i,1)*ds(1)+d(i,2)*ds(2)+d(i,3)*ds(3)+d(i,4)*ds(4)
     &         -s(i,1)*dd(1)-s(i,2)*dd(2)-s(i,3)*dd(3)-s(i,4)*dd(4)
         vec(i)=vec(i)*0.5d+00
         do j=1,3
            mat(i,j)=d(i,1)*d(j,1)+d(i,2)*d(j,2)
     &              +d(i,3)*d(j,3)+d(i,4)*d(j,4)
         enddo
         mat(i,i)=mat(i,i)-ddd
      enddo

      call inv3x3(mat(1,1),mat(1,2),mat(1,3)
     &           ,mat(2,1),mat(2,2),mat(2,3)
     &           ,mat(3,1),mat(3,2),mat(3,3)
     &           ,vec(1),vec(2),vec(3)
     &           ,x1234,y1234,z1234 ,iflag)

      !local_debug=0
      !if (local_debug.gt.0) then
      !  write(*,'(a,3f12.8)') 'using alt ',x1234,y1234,z1234
      !endif

C     ..................................................................
C     NOW FIND THE VOLUME OF THE 4-TRI QUD.
C
      call volume_tri(x1234,y1234,z1234,
     &                x1,y1,z1,
     &                x2,y2,z2,
     &                volqud)
      call volume_tri(x1234,y1234,z1234,
     &                x2,y2,z2,
     &                x3,y3,z3,
     &                voltri)
      volqud=volqud+voltri
      call volume_tri(x1234,y1234,z1234,
     &                x3,y3,z3,
     &                x4,y4,z4,
     &                voltri)
      volqud=volqud+voltri
      call volume_tri(x1234,y1234,z1234,
     &                x4,y4,z4,
     &                x1,y1,z1,
     &                voltri)
      volqud=volqud+voltri
C
      return
      end
C#######################################################################

max_forks_repo_name: daniellivingston/LaGriT


text:
module expt

use utils
use LabFuncs

implicit none

!Length of the exposure (in days)
!There are subroutines below for
!calculating the start and end times
!in JulianDay format
double precision :: t_exp
parameter (t_exp = 30d0)

!Physical energy thresholds and resolution
!Minimum and maximum integration limits for the energy
double precision :: E_th, sigma_E, E_min, E_max, Nclip

!Here, E_th is the threshold energy
!Sigma_E is the energy resolution
!all in keV
!parameter (E_th = 100d-3)
parameter (E_th = 10d-3)
parameter (sigma_E = 3d-3)
!parameter (E_max = 1d0)
parameter (E_max = 0.25d0)

parameter (Nclip = 2d0)

!Don't change this...
!E_min is the minimum energy required for
!integrals over all energies...
parameter (E_min = 1d-5)

!Background parameters
!Events per keV per kg per day (flat spectrum)
double precision :: BG_flat, BG_R0, BG_E0
parameter (BG_flat = 8.0d3)
!parameter (BG_rate = 10.0)
!parameter (BG_rate = 1d-5)
parameter (BG_R0 = 2.2d8)
parameter (BG_E0 = 25d-3) !25 eV characteristic energy

!Mass numbers and mass fractions
double precision :: A_det(2)
double precision :: mass_frac(2)
integer :: N_elements
!parameter (A_det = 73d0)

parameter (N_elements = 2)
parameter (A_det = (/ 16.0d0, 27.0d0 /))
parameter (mass_frac = (/ 0.53d0, 0.47d0 /))

!Latitude and longitude of detector
double precision :: lon_det = 13.576d0
double precision :: lat_det = 45.454d0

!Here we use the values for LNGS

!parameter (lon_det = 13.576d0)
!parameter (lat_det = -45.454d0)
!parameter (lat_det = -45.454d0)

!Mass of detector (in kg)
double precision :: m_det
parameter (m_det = 35d-3)

contains

!----------
!Gaussian resolution smoothing function
function resolution(E1,E2)
    double precision :: E1, E2, resolution

    if ((E1 < 0).or.(E2 < 0).or.((E1-E2)**2 > (Nclip*sigma_E)**2)) then
        resolution = 0
        return
    end if

    resolution = exp(-(E1-E2)**2/(2.0*sigma_E**2))/sqrt(2.0*pi*sigma_E**2)

    !Clip below zero...
    !if (resolution < 0) then
    !    resolution = 0
    !end if

end function resolution

!-----------
!Gaussian resolution integrated over observed energies
function resolution_integrated(E, E1in, E2in)
    double precision :: E, E1, E2, resolution_integrated
    double precision, optional :: E1in, E2in

    if (present(E1in)) then
        E1 = E1in
    else
        E1 = E_th
    end if

    if (present(E2in)) then
        E2 = E2in
    else
        E2 = E_max
    end if

    !Now account for truncation
    if (E < (E2 - Nclip*sigma_E)) then
       E2 = E + Nclip*sigma_E
    end if

    if (E > (E1 + Nclip*sigma_E)) then
       E1 = E - Nclip*sigma_E
    end if

    if (E1 < E2) then
       resolution_integrated = 0.5*(erfun((E2 - E)/(sqrt(2.0)*sigma_E)) + erfun((E - E1)/(sqrt(2.0)*sigma_E)))
    else
       resolution_integrated = 0.0
    end if

end function resolution_integrated

!----------
function t_start()
    double precision :: t_start
    t_start = JulianDay(1, 1, 2018, 0d0)
end function t_start

!----------
function t_end()
    double precision :: t_end
    t_end = t_start() + t_exp
end function t_end

end module expt

max_stars_repo_name: bradkav/EarthScatterLikelihood

max_issues_repo_name: bradkav/EarthScatterLikelihood

max_forks_repo_name: bradkav/EarthScatterLikelihood