text:
Greek life refers to being an active students student member of a social fraternities fraternity or sororities sorority.  Social fraternities and sororities have been a vital part of UC Davis since 1923. They provide a small group living experience that enhances the cocurricular life of every Greek student through academic, social, educational, leadership, and community service activities. There are both national and local fraternities and sororities at UCD with diverse backgrounds and histories.

At first glance, UC Davis can seem overwhelming with its 23,000 students. The Greek community gives students the chance to make a big campus smaller. Fraternities and sororities enable young men and women to establish strong friendships that last beyond their college years. Affiliation provides an opportunity to interact with other students of all ages, backgrounds, and interests allowing for the possibility for members to meet a wide range of people within the Greek community as well as student organizations and activities. Membership offers a network of support while making the transition to college life. Sharing your college experiences with a variety of brothers and sisters will provide bonds and friendships that will last a lifetime.

One of the most gratifying aspects of Greek life is the sense of satisfaction and pride that comes with involvement in community service. Greeks throughout the nation recognize local and national organizations in need of aid by donating time and money through their special philanthropies and service projects. UCD Greeks raise thousands of dollars and devote thousands of hours in handson service each year to a variety of projects that benefit the citizens of Davis and Yolo County. In addition, the Greek community comes together several times per year to perform joint projects for both the campus and the community. Examples include tutoring local children, working at shelters and soup kitchens. Whether raising money or donating time, service is an important part of the Greek experience.

Greek life is a special living and learning environment. Fraternity and sorority chapters are selfgoverning bodies in which the members take on the responsibilities and offices of the organization. This handson experience helps members develop leadership, organization, and communication skills. Chapters and members interact and make connections with other student organizations and departments on campus. Greeks learn the importance of dedication, working with others, responsibility, and selfreliance. Whether you are a natural leader, want to cultivate your skills, or just want to be involved, Greek life will help you develop your unique, individual potential. The Greek community also provides a wide variety of events that help bring members of different fraternities and sororities together, whether through intramurals, educational workshops and speakers, social events, retreats, or philanthropies.

How to get Involved

Currently, there are many fraternities and sororities registered with UC Davis.  Visit IFC to learn more about fraternities in the NorthAmerican Internfraternity Council, and Panhellenic Council to learn more about different sororities at Davis.  Recruitment for these organization is held at different times throughout the year.

Greeks at UC Davis

  Taken from http://greeklife.ucdavis.edu/greeksinaction/greeklifebythenumbers/

  1 out of every 10 UC Davis students belongs to a sorority or fraternity.
  2.977  Cumulative GPA of all UC Davis undergraduates as of Winter 2012.
  2.987  Cumulative GPA of UC Davis fraternity and sorority members.
  4  Number of Greek governing councils providing oversight and organization to member organizations.
  4 of the 12 Associated Students of UC Davis ASUCD Senate Senators, belong to a fraternity or sorority. And so does the ASUCD President!
  16  – Number of preprofessional and community service fraternities and sororities.
  20  – Number of UC Davis sororities and fraternities with their own houses.
  28 – Number of social sororities and fraternities.
  36 – Number of culturallybased fraternities and sororities.
  75  Total number of registered sororities and fraternities at UC Davis.
  1923 – Year of establishment of first national fraternity on campus.
  1973 – Year of establishment of first national sorority on campus.
  2691 – Estimated number of sorority and fraternity members at UC Davis.
  30000   Estimated person hours donated by Greeks to philanthropic causes in 2011.
  $250000  Total estimated funds donated by Greeks to philanthropic causes in 2011, including $24000 raised by Delta Delta Delta for St. Judes Children Research Hospital.

Nationwide Greek Facts

  Information is taken from http://www.nicindy.org/about_us/public_relations/

  9 Million Members Total
  750,000 Undergraduate Members in 12,000 chapters
  800 Campuses in USA & Canada
  Own & Manage $3 BILLION housing
  250,000 students in 8000 facilities
  10 Million Service Hours a Year
  Leaders on Campus
  Serve our campus and community
  Higher graduation rate
  Alumni donate more
  Alumni are more active
  48% of US Presidents
  40% of all Supreme Court Justices
  42% of US Senate
  30% of Congress
  30% Fortune 500 CEOs

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      BLOCK DATA SDR2BD
CSDR2BD
      IMPLICIT INTEGER (A-Z)
C
      INTEGER         RFMTS(40)
C
      COMMON /SDR2X1/ IEIGEN,IELDEF,ITLOAD,ISYMFL,ILOADS,IDISPL,ISTR  ,
     1                IELF  ,IACC  ,IVEL  ,ISPCF ,ITTL  ,ILSYM ,IFROUT,
     2                ISLOAD,IDLOAD,ISORC
C
      COMMON /SDR2X2/ CASECC,CSTM  ,MPT   ,DIT   ,EQEXIN,SIL   ,GPTT  ,
     1                EDT   ,BGPDT ,PG    ,QG    ,UGV   ,EST   ,PHIG  ,
     2                EIGR  ,OPG1  ,OQG1  ,OUGV1 ,OES1  ,OEF1  ,PUGV1 ,
     3                OEIGR ,OPHIG ,PPHIG ,ESTA  ,GPTTA ,HARMS ,XYCDB ,
     4                SCR3  ,PCOMPS,OES1L ,OEF1L
C
      COMMON /SDR2X4/ NAM(2),END   ,MSET  ,ICB(7),OCB(7),MCB(7),DTYPE(8)
     1,               ICSTM ,NCSTM ,IVEC  ,IVECN ,TEMP  ,DEFORM,FILE  ,
     2                BUF1  ,BUF2  ,BUF3  ,BUF4  ,BUF5  ,ANY   ,ALL   ,
     3                TLOADS,ELDEF ,SYMFLG,BRANCH,KTYPE ,LOADS ,SPCF  ,
     4                DISPL ,VEL   ,ACC   ,STRESS,FORCE ,KWDEST,KWDEDT,
     5                KWDGPT,KWDCC ,NRIGDS,STA(2),REI(2),DS0(2),DS1(2),
     6                FRQ(2),TRN(2),BK0(2),BK1(2),CEI(2),PLA(22)      ,
     7                NRINGS,NHARMS,AXIC  ,KNSET ,ISOPL ,STRSPT,DDRMM ,
     8                ISOPL8
C
      EQUIVALENCE     (STA(1),RFMTS(1))
C
C*****
C     DATA DEFINING POSITIONS OF PARAMETERS IN A CASE CONTROL RECORD.
C*****
      DATA  IEIGEN/  5/,IELDEF/  6/,ITLOAD/  7/,ISYMFL/ 16/,ILOADS/ 17/,
     1      IDISPL/ 20/,ISTR  / 23/,IELF  / 26/,IACC  / 29/,IVEL  / 32/,
     2      ISPCF / 35/,ITTL  / 39/,ILSYM /200/,IFROUT/145/,ISLOAD/  4/,
     3      IDLOAD/ 13/,ISORC /136/
C*****
C     DATA DEFINING DATA BLOCK FILE NUMBERS.
C*****
      DATA  CASECC/101/,CSTM  /102/,MPT   /103/,DIT   /104/,EQEXIN/105/,
     1      SIL   /106/,GPTT  /107/,EDT   /108/,BGPDT /109/,PG    /110/,
     2      QG    /111/,UGV   /112/,EST   /113/,PHIG  /112/,EIGR  /110/,
     3      OPG1  /201/,OQG1  /202/,OUGV1 /203/,OES1  /204/,OEF1  /205/,
     4      PUGV1 /206/,OEIGR /201/,OPHIG /203/,PPHIG /206/,ESTA  /301/,
     5      GPTTA /302/,HARMS /137/,XYCDB /114/,SCR3  /303/,PCOMPS/116/,
     6      OES1L /207/,OEF1L /208/
C*****
C     DATA DEFINING RIGID FORMATS.
C*****
      DATA  NRIGDS/ 10   /,
     1      RFMTS / 4HSTAT,4HICS ,
     2              4HREIG,4HEN  ,
     3              4HDS0 ,4H    ,
     4              4HDS1 ,4H    ,
     5              4HFREQ,4H    ,
     6              4HTRAN,4HSNT ,
     7              4HBKL0,4H    ,
     8              4HBKL1,4H    ,
     9              4HCEIG,4HEN  ,
     O              4HPLA ,4H    ,
     1              20*0         /
C*****
C     MISC. DATA.
C*****
      DATA   NAM  / 4HSDR2,4H    /, END/4HEND /, DTYPE/2,3,1,5,4,6,7,8/,
     1       MSET / 1001/ ,ISOPL8/  0  /
C
      END

ext: f


text:
MODULE SYSINFO

!**********************************************************************
!**************** SHARED VARAIBLES AND MATERICES **********************
!**********************************************************************

!**************************************************************
!                  GENERAL CONSTANTS
!**************************************************************
 REAL(4),PARAMETER :: PI=4.0d0*ATAN(1.0d0)
 REAL(4),PARAMETER :: KB=1.3807E-23
 REAL(4),PARAMETER :: Vc=2.9979E+8
 REAL(4),PARAMETER :: MU0=4.0E-7*PI
 REAL(4),PARAMETER :: EPSILON0=8.8542E-12
 REAL(4),PARAMETER :: N_Avogaros=6.023E23

!**************************************************************
!                    EARTH RADIUS
!**************************************************************
 REAL(4),PARAMETER :: Re=6378.1

!**************************************************************
!                    SYSTEM STATUS
!**************************************************************
 LOGICAL                :: SYSRESTART        =.FALSE.
!**************************************************************
!         SYSTEM GRID COORDINATES AND PARAMETERS
!**************************************************************
!********************** GRIDING SYSTEM ************************
 LOGICAL                 :: RECTGRID         =.TRUE.
 LOGICAL                 :: SPHRGRID         =.FALSE.
 LOGICAL                 :: GEOGRAPHICGRID   =.TRUE.
 LOGICAL                 :: GEOMAGNETICGRID  =.FALSE.
!**************** PRIMATRY GRIDING SYSTEM *********************
 LOGICAL                 :: pRECTGRID         =.FALSE.
 LOGICAL                 :: pSPHRGRID         =.FALSE.
 LOGICAL                 :: pGEOGRAPHICGRID   =.FALSE.
 LOGICAL                 :: pGEOMAGNETICGRID  =.FALSE.
!**************** SECONDARY GRIDING SYSTEM ********************
 LOGICAL                 :: sRECTGRID         =.FALSE.
 LOGICAL                 :: sSPHRGRID         =.FALSE.
 LOGICAL                 :: sGEOGRAPHICGRID   =.FALSE.
 LOGICAL                 :: sGEOMAGNETICGRID  =.FALSE.
!********************** GRID SPACINGS *************************
 LOGICAL                 :: EQUISPACED       =.TRUE.
 LOGICAL                 :: XEQUISPACED      =.FALSE.
 LOGICAL                 :: YEQUISPACED      =.FALSE.
 LOGICAL                 :: ZEQUISPACED      =.FALSE.
 LOGICAL                 :: CHEBYSHEVSPACED  =.FALSE.
 LOGICAL                 :: XCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: YCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: ZCHEBYSHEVSPACED =.FALSE.
 LOGICAL                 :: LEGENDERSPACED   =.FALSE.
 LOGICAL                 :: XLEGENDERSPACED  =.FALSE.
 LOGICAL                 :: YLEGENDERSPACED  =.FALSE.
 LOGICAL                 :: ZLEGENDERSPACED  =.FALSE.
!************ RECTANGLE NUMBER OF R-GRID POINTS ***************
 INTEGER(4)              :: XDIM=1
 INTEGER(4)              :: YDIM=1
 INTEGER(4)              :: ZDIM=1
!*************** R-SPACE RECTANGLE DIMENSIONS RANGES ******************
 REAL(8)                 :: Xsrt=   0.0
 REAL(8)                 :: Xend=   0.0
 REAL(8)                 :: Ysrt= -16.0*PI
 REAL(8)                 :: Yend=  16.0*PI
 REAL(8)                 :: Zsrt=   0.0*PI
 REAL(8)                 :: Zend=  32.0*PI
!*************** GEO DIMENSIONS RANGES ******************
 REAL(4)                 :: srtLAT= - 0.0
 REAL(4)                 :: endLAT=   0.0
 REAL(4)                 :: srtLON= -0.000050
 REAL(4)                 :: endLON=  0.000050
 REAL(4)                 :: srtALT=  105.000
 REAL(4)                 :: endALT=  105.100
!*************** RECTANGLE R-SPACE ARRAYS **********************
 REAL(8),    ALLOCATABLE :: X1D(:),X2D(:,:),X3D(:,:,:)
 REAL(8),    ALLOCATABLE :: Y1D(:),Y2D(:,:),Y3D(:,:,:)
 REAL(8),    ALLOCATABLE :: Z1D(:),Z2D(:,:),Z3D(:,:,:)
!*************** GEO R-SPACE ARRAYS ********************
 REAL(4),    ALLOCATABLE :: LAT1D(:)
 REAL(4),    ALLOCATABLE :: LON1D(:)
 REAL(4),    ALLOCATABLE :: ALT1D(:)

!**************************************************************
!************** LOCAL TIME AND DATE RANGE MATRICES ************
!**************************************************************
!INTEGER(4)              :: srtLT=120000,endLT=130000,stpLT=10000
!INTEGER(4)              :: srtDT=19870312,endDT=19870312
 INTEGER(4)              :: srtLT=10000,endLT=20000,stpLT=10000
 INTEGER(4)              :: srtDT=20080320,endDT=20080320
 INTEGER(4), ALLOCATABLE :: LTHURMAT(:),LTMINMAT(:),LTSECMAT(:)
 INTEGER(4), ALLOCATABLE :: DTYYYYMAT(:),DTMMMAT(:),DTDDMAT(:)
 INTEGER(4), ALLOCATABLE :: DTMMDDMAT(:)
 INTEGER(4), ALLOCATABLE :: LTMAT(:),DTMAT(:)

!**************************************************************
!                 MISCELLIOUS VARIABLES
!**************************************************************

 CONTAINS

 SUBROUTINE WHATISTIME(NOWTIME)
  IMPLICIT NONE
 !character(8)  :: date
 !character(10) :: time
 !character(5)  :: zone
  integer       :: values(8)
  INTEGER(4)    :: NOWTIME(*)
  !using keyword arguments
  call date_and_time(VALUES=values)
  NOWTIME(1:3)=values(1:3)
  NOWTIME(4:7)=values(5:8)
 !PRINT*, NOWTIME(1)
 !call date_and_time(date,time,zone,values)
 !call date_and_time(DATE=date,ZONE=zone)
 !call date_and_time(TIME=time)
 !call date_and_time(VALUES=values)
 !print '(a,2x,a,2x,a)', date, time, zone
 !print '(8i5)', values
  RETURN
 END SUBROUTINE WHATISTIME

!********************************************************
!  CHANGE THE CASE OF A STRING TO LOWER AND UPPER CASE
!********************************************************

 FUNCTION to_UpperCase (str)
 !==============================
 !Changes a string to upper case
 !==============================
  IMPLICIT NONE
  Character(*), Intent(In) :: str
  Character(LEN(str))      :: to_UpperCase
  Character(LEN(str))      :: string

  Integer :: ic, i

  Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

 !Capitalize each letter if it is lowecase
  string = str
  do i = 1, LEN_TRIM(str)
   ic = INDEX(low, str(i:i))
   if (ic > 0) string(i:i) = cap(ic:ic)
  end do

  to_UpperCase=trim(string)

  RETURN
 End Function to_UpperCase

 FUNCTION to_LowerCase (str)
 !==============================
 !Changes a string to lower case
 !==============================
  IMPLICIT NONE
  Character(*), Intent(In) :: str
  Character(LEN(str))      :: to_LowerCase
  Character(LEN(str))      :: string

  Integer :: ic, i

  Character(26), Parameter :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  Character(26), Parameter :: low = 'abcdefghijklmnopqrstuvwxyz'

 !Capitalize each letter if it is lowecase
  string = str
  do i = 1, LEN_TRIM(str)
   ic = INDEX(cap, str(i:i))
   if (ic > 0) string(i:i) = low(ic:ic)
  end do

  to_LowerCase=TRIM(string)

  RETURN
 END FUNCTION to_LowerCase

END MODULE SYSINFO

max_stars_repo_name: ehabhassan/iMust

max_issues_repo_name: ehabhassan/iMust

max_forks_repo_name: ehabhassan/iMust


SUBROUTINE ConvertCSRtoCOO(tmpSM,SM)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (SparseArray_CSR) :: tmpSM
TYPE (SparseArray_COO) :: SM
INTEGER :: nnz, nrow, ierr, job
!INTEGER, DIMENSION(:), ALLOCATABLE :: iwk, indu

SM%nnz = tmpSM%nnz

ALLOCATE( SM%val(tmpSM%nnz)        )
ALLOCATE( SM%col_ind(tmpSM%nnz)    )
ALLOCATE( SM%row_ptr(tmpSM%nnz)    )

! FIXME: job=3 used here, but can be made more efficient, by only redirecting pointers?
job = 3
CALL csrcoo(tmpSM%nrow,job,tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1),&
			tmpSM%val,tmpSM%col_ind,tmpSM%row_ptr,&
			tmpSM%row_ptr(tmpSM%nrow+1) - tmpSM%row_ptr(1),&
			SM%val,SM%row_ptr,SM%col_ind,ierr)

! Release CSR matrix
DEALLOCATE( tmpSM%val, tmpSM%row_ptr, tmpSM%col_ind)

END SUBROUTINE ConvertCSRtoCOO


text:
      SUBROUTINE NEMTAB(LUN,NEMO,IDN,TAB,IRET)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    NEMTAB
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE
C   INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS
C   IN COMMON BLOCK /TABABD/) AND, IF FOUND, RETURNS INFORMATION ABOUT
C   THAT MNEMONIC FROM WITHIN THESE ARRAYS.  OTHERWISE, IT CHECKS
C   WHETHER NEMO IS A TABLE C OPERATOR DESCRIPTOR AND, IF SO, DIRECTLY
C   COMPUTES AND RETURNS SIMILAR INFORMATION ABOUT THAT DESCRIPTOR.
C   THIS SUBROUTINE MAY BE USEFUL TO APPLICATION PROGRAMS WHICH WANT
C   TO CHECK WHETHER A PARTICULAR MNEMONIC IS IN THE DICTIONARY.  IN
C   THIS CASE, BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF MUST FIRST BE
C   CALLED TO STORE THE DICTIONARY TABLE INTERNALLY, AND BUFR ARCHIVE
C   LIBRARY SUBROUTINE STATUS MUST BE CALLED TO CONNECT THE LOGICAL
C   UNIT NUMBER FOR THE BUFR FILE OPENED IN OPENBF TO LUN.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C                           BUFR FILES UNDER THE MPI)
C 2000-09-19  J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA
C                           USING THE OPERATOR DESCRIPTORS (BUFR TABLE
C                           C) FOR CHANGING WIDTH AND CHANGING SCALE
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
C 2005-11-29  J. ATOR    -- ADDED SUPPORT FOR 207 AND 208 OPERATORS
C
C USAGE:    CALL NEMTAB (LUN, NEMO, IDN, TAB, IRET)
C   INPUT ARGUMENT LIST:
C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C     NEMO     - CHARACTER*(*): MNEMONIC TO SEARCH FOR
C
C   OUTPUT ARGUMENT LIST:
C     IDN      - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE
C                CORRESPONDING TO NEMO (IF NEMO WAS FOUND)
C     TAB      - CHARACTER*1: INTERNAL TABLE ARRAY IN WHICH NEMO WAS
C                FOUND:
C                     'B' = Table B array
C                     'C' = Table C array
C                     'D' = Table D array
C     IRET     - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB
C                       0 = NEMO was not found within any of the Table
C                           B, C, or D arrays
C
C REMARKS:
C    THIS ROUTINE CALLS:        IFXY
C    THIS ROUTINE IS CALLED BY: CHEKSTAB CMSGINI  ELEMDX   MSGINI
C                               SEQSDX   TABSUB   UFBDMP   UFBQCD
C                               UFDUMP   UPFTBV
C                               Also called by application programs
C                               (see ABSTRACT).
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
     .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
     .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
     .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
     .                TABD(MAXTBD,NFILES)

      CHARACTER*(*) NEMO
      CHARACTER*600 TABD
      CHARACTER*128 TABB
      CHARACTER*128 TABA
      CHARACTER*8   NEMT
      CHARACTER*1   TAB
      LOGICAL       FOLVAL

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

      FOLVAL = NEMO(1:1).EQ.'.'
      IRET = 0
      TAB = ' '

C  LOOK FOR NEMO IN TABLE B
C  ------------------------

      DO 1 I=1,NTBB(LUN)
      NEMT = TABB(I,LUN)(7:14)
      IF(NEMT.EQ.NEMO) THEN
         IDN  = IDNB(I,LUN)
         TAB  = 'B'
         IRET = I
         GOTO 100
      ELSEIF(FOLVAL.AND.NEMT(1:1).EQ.'.') THEN
         DO J=2,LEN(NEMT)
         IF(NEMT(J:J).NE.'.' .AND. NEMT(J:J).NE.NEMO(J:J)) GOTO 1
         ENDDO
         IDN  = IDNB(I,LUN)
         TAB  = 'B'
         IRET = I
         GOTO 100
      ENDIF
1     ENDDO

C  DON'T LOOK IN TABLE D FOR FOLLOWING VALUE-MNEMONICS
C  ---------------------------------------------------

      IF(FOLVAL) GOTO 100

C  LOOK IN TABLE D IF WE GOT THIS FAR
C  ----------------------------------

      DO I=1,NTBD(LUN)
      NEMT = TABD(I,LUN)(7:14)
      IF(NEMT.EQ.NEMO) THEN
         IDN  = IDND(I,LUN)
         TAB  = 'D'
         IRET = I
         GOTO 100
      ENDIF
      ENDDO

C  IF STILL NOTHING, CHECK HERE FOR TABLE C OPERATOR DESCRIPTORS
C  -------------------------------------------------------------

      IF(NEMO(1:3).EQ.'201' .OR.
     .   NEMO(1:3).EQ.'202' .OR.
     .   NEMO(1:3).EQ.'206' .OR.
     .   NEMO(1:3).EQ.'207' .OR.
     .   NEMO(1:3).EQ.'208' ) THEN
         READ(NEMO,'(1X,I2)') IRET
         IDN = IFXY(NEMO)
         TAB = 'C'
         GOTO 100
      ENDIF

C  EXIT
C  ----

100   RETURN
      END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
> This page is an example/demo set up to get suggestions from the rest of you.  I.e. not a contest yet. <

One of the many things that make the Front Page Wiki so fun is the great Photography photography submitted by users.  However, many of the Front Page Wikis PageCount pages are still textonly.  With this in mind, we are holding a Wiki Photo Contest to stimulate more photo submissions.  The winning photograph(s) will be proudly displayed in a future Next Featured Page Featured Page.  The submission deadline is (subject to your/community input).

 Two Contest Categories
 1. Illustrative photos (such as would be found on any given page)
 2. Artistic photos (for the Photography page)

 Guidelines
 1. As with all content, the photos should be relevant to Davis Davis, California.
 2. Uploaded photo file should be no larger than 100k.
 3. All submissions should be original or submitted with permission of the photographer.  See the Copyrights page for more info.

 Past Photo Contest Winners
 0. your name could be here


text:
module grid_pda_geometry

  use core_lib
  use type_grid_cell
  use grid_geometry
  implicit none
  save

  private
  public :: geometrical_factor
  public :: check_allowed_pda

contains

  real(dp) function geometrical_factor(wall, cell)
    implicit none
    integer, intent(in) :: wall
    type(grid_cell), intent(in) :: cell
    select case(wall)
    case(1)
       geometrical_factor = 4. * geo%w1(cell%i1)**2/(geo%w1(cell%i1) + geo%w1(cell%i1+1))**2
    case(2)
       geometrical_factor = 4. * geo%w1(cell%i1+1)**2/(geo%w1(cell%i1) + geo%w1(cell%i1+1))**2
    case(3)
       geometrical_factor = 2. * geo%wsint(cell%i2) / (geo%wsint(cell%i2) + geo%wsint(cell%i2+1))
    case(4)
       geometrical_factor = 2. * geo%wsint(cell%i2+1) / (geo%wsint(cell%i2) + geo%wsint(cell%i2+1))
    case default
       geometrical_factor = 1._dp
    end select
  end function geometrical_factor

  subroutine check_allowed_pda(do_pda)
    implicit none
    logical,intent(inout) :: do_pda(:)
    integer :: i1, i2, i3, ic
    do i2=1,geo%n2
       do i3=1,geo%n3
          ic = cell_id(1, i2, i3, geo)
          do_pda(ic) = .false.
          ic = cell_id(geo%n1, i2, i3, geo)
          do_pda(ic) = .false.
       end do
    end do
    do i1=1,geo%n1
       do i3=1,geo%n3
          ic = cell_id(i1, 1, i3, geo)
          do_pda(ic) = .false.
          ic = cell_id(i1, geo%n2, i3, geo)
          do_pda(ic) = .false.
       end do
    end do
  end subroutine check_allowed_pda

end module grid_pda_geometry

max_stars_repo_name: christopherlovell/hyperion

max_issues_repo_name: christopherlovell/hyperion

max_forks_repo_name: christopherlovell/hyperion


text:
      subroutine tsolqu(np,x,px,y,py,z,gp,dv,sx,sy,sz,
     $     al,ak,bz0,ak0x,ak0y,ibsi,eps0)
      use tsolz
      use kradlib, only:bsi
      use mathfun
      implicit none
      type (tzparams) tz
      integer*4 ,intent(in):: np,ibsi
      real*8 ,intent(inout):: x(np),px(np),y(np),py(np),z(np),dv(np),
     $     gp(np),sx(np),sy(np),sz(np)
      real*8 ,intent(in):: al,ak,eps0,bz0,ak0x,ak0y
      real*8, parameter::phieps=1.d-7,epsdef=0.2d0
      integer*4 i,n,ndiv
      real*8 bz,a,c,akk,eps,bw,dw,r,ap,dpz,aln0,
     $     u1,u1w,u2,u2w,v1,v1w,v2,v2w,
     $     dx0,dy0,xi,yi,a12,a14,a22,a24,pxi,pyi,
     $     awu,dwu,dz1,dz2
        associate (
     $     s1=>tz%tz0%s1,dc1=>tz%tz0%dc1,xs1=>tz%tz0%xs1,
     $     sh2=>tz%tz0%sh2,dch2=>tz%tz0%dch2,xsh2=>tz%tz0%xsh2,
     $     akkp=>tz%tz0%akkp,bzp=>tz%tz0%bzp,
     $     w1=>tz%tz0%w1,phi1=>tz%tz0%phi1,
     $     w2=>tz%tz1%w2,ws=>tz%tz1%ws,w12=>tz%tz1%w12,wd=>tz%tz1%wd,
     $     phi2=>tz%tz1%phi2,wss=>tz%tz1%wss,csw1=>tz%tz1%csw1,
     $     csws=>tz%tz1%csws,ca1=>tz%tz1%ca1,dcw1=>tz%tz1%dcw1,
     $     dcw2=>tz%tz1%dcw2,cr2=>tz%tz1%cr2,cr3=>tz%tz1%cr3,
     $     g1=>tz%tz1%g1,g2=>tz%tz1%g2,cxs1=>tz%tz1%cxs1,
     $     cxs2=>tz%tz1%cxs2,aw1=>tz%tz1%aw1,aw2=>tz%tz1%aw2,
     $     wr1=>tz%tz1%wr1,wr2=>tz%tz1%wr2,dxs=>tz%tz1%dxs)
      if(ak*al .lt. 0.d0)then
        write(*,*)'tsolqu-implementation error ',al,ak,bz0
        stop
      elseif(ak .eq. 0.d0)then
        call tdrift(np,x,px,y,py,z,gp,dv,sx,sy,sz,
     $       al,bz0,ak0x,ak0y,.false.)
        return
      endif
      bz=bz0
      eps=merge(epsdef,epsdef*eps0,eps0 .eq. 0.d0)
      ndiv=1+int(abs(al*hypot(ak,bz)/eps))
c      ndiv=1+int(abs(al*dcmplx(ak,bz))/eps)
      aln0=al/ndiv
      dx0=ak0x/ak
      dy0=ak0y/ak
      akk=ak/al
      if(bz .eq. 0.d0)then
        do concurrent (i=1:np)
          call tzsetparam0(tz%tz0,gp(i),aln0,akk)
          if(ibsi .eq. 1)then
            bsi(i)=akk*(x(i)+dx0)*(y(i)+dy0)
          elseif(ibsi .ge. 0)then
            bsi(i)=0.d0
          endif
          do n=1,ndiv
            pxi=px(i)
            pyi=py(i)
            ap=pxi**2+pyi**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*merge(aln0*.5d0,aln0,n .eq. 1)
            x(i)=x(i)+pxi*r
            y(i)=y(i)+pyi*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            u1 =   xi*dc1 +pxi*s1/w1
            u2 =-xi*w1*s1 +pxi*dc1
            v1 =   yi*dch2+pyi*sh2/w1
            v2 = yi*w1*sh2+pyi*dch2
            x(i) =x(i)+u1
            px(i)=pxi +u2
            y(i) =y(i)+v1
            py(i)=pyi +v2
            z(i) =z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
     $           -0.25d0*(
     $           w1*(xi**2*xs1-yi**2*xsh2)
     $           +(ap-dv(i))*aln0
     $           +u1*px(i)+xi*pxi*dc1
     $           +v1*py(i)+yi*pyi*dch2)
          enddo
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln0*.5d0
          x(i)=x(i)+px(i)*r
          y(i)=y(i)+py(i)*r
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
          if(ibsi .eq. 2)then
            bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)
          endif
        enddo
      else
        do concurrent (i=1:np)
          call tzsetparams(tz,gp(i),aln0,akk,bz)
          if(ibsi .eq. 1)then
            bsi(i)=akk*(x(i)+dx0)*(y(i)+dy0)+bzp*al
          elseif(ibsi .ge. 0)then
            bsi(i)=bzp*al
          endif
          px(i)=px(i)+bzp*y(i)*.5d0
          py(i)=py(i)-bzp*x(i)*.5d0
          do n=1,ndiv
            ap=px(i)**2+py(i)**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*merge(aln0*.5d0,aln0,n .eq. 1)
            call xsincos(r*bzp,a24,a12,a22,a14)
            pxi=px(i)
            x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
            y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
            pxi  =      a22*pxi+a24*py(i)
            pyi  =     -a24*pxi+a22*py(i)
            z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            a=  (w2*ws*xi-bzp*pyi  )*wss
            bw= (  ws*pxi-bzp*w2*yi)*wss
            c=  (w1*wd*xi+pyi  )*wss
            dw= ( -wd*pxi+w1*yi)*wss
            u1w= a*dc1 +bw*s1
            u2w=-a*s1  +bw*dc1
            v1w= c*dch2+dw*sh2
            v2w= c*sh2 +dw*dch2
            x(i) =x(i)+u1w      +v1w*bzp
            px(i)=pxi +u2w*w1   +v2w*w2*bzp
            y(i) =y(i)+wd*u2w   +ws*v2w
            py(i)=pyi -wd*u1w*w1+ws*v1w*w2
            awu=a/ws*w1
            dwu=dw*w2
            call tztafs(tz, awu, pxi,pyi,aw1, ws, w12,wss, g1, dz1)
            call tztafs(tz,-dwu,-pyi,pxi,aw2,-w12,ws, -wss,g2, dz2)
            z(i)=z(i)+
     $           bzp*(-((awu*dwu*dxs**2)/akkp) +
     $           ca1*pxi*pyi*wss)
     $           +dz1+dz2-aln0*dv(i)
          enddo
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln0*.5d0
          call xsincos(r*bzp,a24,a12,a22,a14)
          pxi=px(i)
          x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
          y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
          px(i)=      a22*pxi+a24*py(i)-bzp*y(i)*.5d0
          py(i)=     -a24*pxi+a22*py(i)+bzp*x(i)*.5d0
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
          if(ibsi .eq. 2)then
            bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)+bzp*al
          endif
        enddo
      endif
      return
      end associate
      end

      subroutine tsolqum(np,x,px,y,py,z,gp,dv,sx,sy,sz,
     $     al,ak,bz,ak0x,ak0y,ibsi,eps0,tzs,ini)
      use tsolz
      use kradlib, only:bsi
c      use tmacro,only:l_track
      use mathfun
      implicit none
      integer*4 ,intent(in):: np,ibsi
      type (tzparams) ,intent(inout):: tzs(np)
c      type (tzparams)  tzs(np),tz
      real*8 ,intent(inout):: x(np),px(np),y(np),py(np),z(np),dv(np),
     $     gp(np),sx(np),sy(np),sz(np)
      real*8 ,intent(in):: al,ak,eps0,bz,ak0x,ak0y
      logical*4 ,intent(in):: ini
      real*8, parameter::phieps=1.d-7,epsdef=0.2d0
      integer*4 i,n,ndiv
      real*8 a,c,akk,eps,bw,dw,r,ap,dpz,aln0,
     $     u1,u1w,u2,u2w,v1,v1w,v2,v2w,
     $     dx0,dy0,xi,yi,a12,a14,a22,a24,pxi,pyi,
     $     awu,dwu,dz1,dz2
      if(ak*al .lt. 0.d0)then
        write(*,*)'tsolqu-implementation error ',al,ak,bz
        stop
      elseif(ak .eq. 0.d0)then
        call tdrift(np,x,px,y,py,z,gp,dv,sx,sy,sz,
     $       al,bz,ak0x,ak0y,.false.)
        return
      endif
      eps=merge(epsdef,epsdef*eps0,eps0 .eq. 0.d0)
      ndiv=1+int(abs(al*hypot(ak,bz)/eps))
c      ndiv=1+int(abs(al*dcmplx(ak,bz))/eps)
      aln0=al/ndiv
      dx0=ak0x/ak
      dy0=ak0y/ak
      akk=ak/al
      if(bz .eq. 0.d0)then
        if(ini)then
          do concurrent (i=1:np)
            call tzsetparam0(tzs(i)%tz0,gp(i),aln0,akk)
          enddo
        endif
        do concurrent (i=1:np)
          associate (
     $         w1=>tzs(i)%tz0%w1,s1=>tzs(i)%tz0%s1,dc1=>tzs(i)%tz0%dc1,
     $         xs1=>tzs(i)%tz0%xs1,sh2=>tzs(i)%tz0%sh2,
     $         dch2=>tzs(i)%tz0%dch2,xsh2=>tzs(i)%tz0%xsh2)
          if(ibsi .eq. 1)then
            bsi(i)=akk*(x(i)+dx0)*(y(i)+dy0)
          elseif(ibsi .ge. 0)then
            bsi(i)=0.d0
          endif
          do n=1,ndiv
            pxi=px(i)
            pyi=py(i)
            ap=pxi**2+pyi**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*merge(aln0*.5d0,aln0,n .eq. 1)
            x(i)=x(i)+pxi*r
            y(i)=y(i)+pyi*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            u1 =   xi*dc1 +pxi*s1/w1
            u2 =-xi*w1*s1 +pxi*dc1
            v1 =   yi*dch2+pyi*sh2/w1
            v2 = yi*w1*sh2+pyi*dch2
            x(i) =x(i)+u1
            px(i)=pxi +u2
            y(i) =y(i)+v1
            py(i)=pyi +v2
            z(i) =z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
     $           -0.25d0*(
     $           w1*(xi**2*xs1-yi**2*xsh2)
     $           +(ap-dv(i))*aln0
     $           +u1*px(i)+xi*pxi*dc1
     $           +v1*py(i)+yi*pyi*dch2)
          enddo
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln0*.5d0
          x(i)=x(i)+px(i)*r
          y(i)=y(i)+py(i)*r
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
          if(ibsi .eq. 2)then
            bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)
          endif
          end associate
        enddo
      else
        if(ini)then
          do concurrent (i=1:np)
            call tzsetparams(tzs(i),gp(i),aln0,akk,bz)
          enddo
        endif
        do concurrent (i=1:np)
          associate (
     $         w1=>tzs(i)%tz0%w1,bzp=>tzs(i)%tz0%bzp,
     $         akkp=>tzs(i)%tz0%akkp,pr=>tzs(i)%tz0%pr,
     $         s1=>tzs(i)%tz0%s1,dc1=>tzs(i)%tz0%dc1,
     $         xs1=>tzs(i)%tz0%xs1,sh2=>tzs(i)%tz0%sh2,
     $         dch2=>tzs(i)%tz0%dch2,xsh2=>tzs(i)%tz0%xsh2,
     $         w2=>tzs(i)%tz1%w2,ws=>tzs(i)%tz1%ws,w12=>tzs(i)%tz1%w12,
     $         wd=>tzs(i)%tz1%wd,wss=>tzs(i)%tz1%wss,
     $         ca1=>tzs(i)%tz1%ca1,dxs=>tzs(i)%tz1%dxs,
     $         g1=>tzs(i)%tz1%g1,g2=>tzs(i)%tz1%g2,
     $         aw1=>tzs(i)%tz1%aw1,aw2=>tzs(i)%tz1%aw2)
          if(ibsi .eq. 1)then
            bsi(i)=akk*(x(i)+dx0)*(y(i)+dy0)+bzp*al
          elseif(ibsi .ge. 0)then
            bsi(i)=bzp*al
          endif
          px(i)=px(i)+bzp*y(i)*.5d0
          py(i)=py(i)-bzp*x(i)*.5d0
          do n=1,ndiv
            ap=px(i)**2+py(i)**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*merge(aln0*.5d0,aln0,n .eq. 1)
            call xsincos(r*bzp,a24,a12,a22,a14)
            pxi=px(i)
            x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
            y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
            pxi  =      a22*pxi+a24*py(i)
            pyi  =     -a24*pxi+a22*py(i)
            z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            a=  (w2*ws*xi-bzp*pyi  )*wss
            bw= (  ws*pxi-bzp*w2*yi)*wss
            c=  (w1*wd*xi+pyi  )*wss
            dw= ( -wd*pxi+w1*yi)*wss
            u1w= a*dc1 +bw*s1
            u2w=-a*s1  +bw*dc1
            v1w= c*dch2+dw*sh2
            v2w= c*sh2 +dw*dch2
            x(i) =x(i)+u1w      +v1w*bzp
            px(i)=pxi +u2w*w1   +v2w*w2*bzp
            y(i) =y(i)+wd*u2w   +ws*v2w
            py(i)=pyi -wd*u1w*w1+ws*v1w*w2
            awu=a/ws*w1
            dwu=dw*w2
            call tztafs(tzs(i), awu, pxi,pyi,aw1, ws, w12,wss, g1, dz1)
            call tztafs(tzs(i),-dwu,-pyi,pxi,aw2,-w12,ws, -wss,g2, dz2)
            z(i)=z(i)+
     $           bzp*(-((awu*dwu*dxs**2)/akkp) +
     $           ca1*pxi*pyi*wss)
     $           +dz1+dz2-aln0*dv(i)
          enddo
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln0*.5d0
          call xsincos(r*bzp,a24,a12,a22,a14)
          pxi=px(i)
          x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
          y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
          px(i)=      a22*pxi+a24*py(i)-bzp*y(i)*.5d0
          py(i)=     -a24*pxi+a22*py(i)+bzp*x(i)*.5d0
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
          if(ibsi .eq. 2)then
            bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)+bzp*al
          endif
          end associate
        enddo
      endif
      return
      end

      subroutine tsolqur(np,x,px,y,py,z,gp,dv,sx,sy,sz,al,ak,
     $     bz0,ak0x,ak0y,eps0,alr)
      use tsolz
      use kradlib, only:bsi,tradk
      use ffs_flag, only:ndivrad
      use photontable,only:tgswap,pcvt
      use mathfun
      implicit none
      type (tzparams) tz
      integer*4 ,intent(in):: np
      real*8 ,intent(inout):: x(np),px(np),y(np),py(np),z(np),dv(np),
     $     gp(np),sx(np),sy(np),sz(np)
      real*8 ,intent(in):: al,ak,eps0,bz0,ak0x,ak0y
      real*8 ,intent(out):: alr
      real*8, parameter::phieps=1.d-7,epsdef=0.2d0,arad=0.01d0
      integer*4 ,parameter ::ndivmax=1000
      integer*4 i,n,ndiv
      real*8 bz,a,c,akk,eps,bw,dw,r,ap,dpz,aka,b,d,
     $     u1,u1w,u2,u2w,v1,v1w,v2,v2w,
     $     dx0,dy0,xi,yi,a12,a14,a22,a24,pxi,pyi,
     $     awu,dwu,dz1,dz2
        associate (
     $       c1=>tz%tz0%c1,s1=>tz%tz0%s1,dc1=>tz%tz0%dc1,
     $       xs1=>tz%tz0%xs1,ch2=>tz%tz0%ch2,sh2=>tz%tz0%sh2,
     $       dch2=>tz%tz0%dch2,xsh2=>tz%tz0%xsh2,pr=>tz%tz0%pr,
     $       akkp=>tz%tz0%akkp,aln=>tz%tz0%aln,bzp=>tz%tz0%bzp,
     $       w1=>tz%tz0%w1,phi1=>tz%tz0%phi1,
     $       w2=>tz%tz1%w2,ws=>tz%tz1%ws,w12=>tz%tz1%w12,wd=>tz%tz1%wd,
     $       phi2=>tz%tz1%phi2,wss=>tz%tz1%wss,csw1=>tz%tz1%csw1,
     $       csws=>tz%tz1%csws,ca1=>tz%tz1%ca1,dcw1=>tz%tz1%dcw1,
     $       dcw2=>tz%tz1%dcw2,cr2=>tz%tz1%cr2,cr3=>tz%tz1%cr3,
     $       g1=>tz%tz1%g1,g2=>tz%tz1%g2,cxs1=>tz%tz1%cxs1,
     $       cxs2=>tz%tz1%cxs2,aw1=>tz%tz1%aw1,aw2=>tz%tz1%aw2,
     $       wr1=>tz%tz1%wr1,wr2=>tz%tz1%wr2,dxs=>tz%tz1%dxs)
      if(ak*al .lt. 0.d0)then
        write(*,*)'tsolqur-implementation error ',al,ak,bz0
        stop
      elseif(ak .eq. 0.d0)then
        call tdrift(np,x,px,y,py,z,gp,dv,sx,sy,sz,
     $       al,bz0,ak0x,ak0y,.false.)
        alr=al
        return
      endif
      bz=bz0
      eps=merge(epsdef,epsdef*eps0,eps0 .eq. 0.d0)
      aka=hypot(ak,bz)
      ndiv=1+int(abs(al)*aka/eps)
      ndiv=min(ndivmax,
     $     max(ndiv,ndivrad(hypot(ak0x,ak0y),ak,bz,eps0)))
      aln=al/ndiv
      dx0=ak0x/ak
      dy0=ak0y/ak
      akk=ak/al
      if(bz .eq. 0.d0)then
        alr=aln*0.5d0
        do n=1,ndiv
c!$OMP PARALLEL
c!$OMP DO
          do i=1,np
            call tzsetparam0(tz%tz0,gp(i),aln,akk)
            bsi(i)=merge(akk*(x(i)+dx0)*(y(i)+dy0),0.d0,n .eq. 1)
            ap=px(i)**2+py(i)**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*alr
            x(i)=x(i)+px(i)*r
            y(i)=y(i)+py(i)*r
            z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            b=px(i)
            d=py(i)
            u1 =   xi*dc1 +b*s1/w1
            u2 =-xi*w1*s1 +b*dc1
            v1 =   yi*dch2+d*sh2/w1
            v2 = yi*w1*sh2+d*dch2
            x(i) =x(i) +u1
            px(i)=px(i)+u2
            y(i) =y(i) +v1
            py(i)=py(i)+v2
            z(i) =z(i)-0.25d0*(
     $           w1*(xi**2*xs1-yi**2*xsh2)
     $           +(b**2+d**2)*aln
     $           +u1*(u2+b)+xi*b*dc1
     $           +v1*(v2+d)+yi*d*dch2)
     $           -dv(i)*aln
            if(n .eq. ndiv)then
              bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)
            endif
          enddo
c!$OMP END DO
c!$OMP END PARALLEL
          alr=aln
          call tradk(np,x,px,y,py,z,gp,dv,sx,sy,sz,alr,0.d0)
          pcvt%fr0=pcvt%fr0+alr/al
        enddo
        do i=1,np
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln*0.5d0
          x(i)=x(i)+px(i)*r
          y(i)=y(i)+py(i)*r
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
        enddo
      else
        do i=1,np
          bzp=bz/(1.d0+gp(i))
          px(i)=px(i)+bzp*y(i)*.5d0
          py(i)=py(i)-bzp*x(i)*.5d0
        enddo
        alr=aln*0.5d0
        do n=1,ndiv
          do i=1,np
            call tzsetparams(tz,gp(i),aln,akk,bz)
            bsi(i)=merge(akk*(x(i)+dx0)*(y(i)+dy0)+bzp*alr,
     $           bzp*alr,n .eq. 1)
            ap=px(i)**2+py(i)**2
            dpz=sqrt1(-ap)
            r=-dpz/(1.d0+dpz)*alr
            call xsincos(r*bzp,a24,a12,a22,a14)
            pxi=px(i)
            x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
            y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
            pxi  =     a22*pxi+a24*py(i)
            pyi  =    -a24*pxi+a22*py(i)
            z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
            xi=x(i)+dx0
            yi=y(i)+dy0
            a=  (w2*ws*xi-bzp*pyi)*wss
            bw= (ws*pxi-bzp*w2*yi)*wss
            c=  (w1*wd*xi +pyi)*wss
            dw= (-wd*pxi+w1*yi)*wss
            u1w= a*dc1+bw*s1
            u1=u1w*w1
            u2w=-a*s1 +bw*dc1
            u2=u2w*w1
            v1w= c*dch2+dw*sh2
            v1=v1w*w2
            v2w= c*sh2 +dw*dch2
            v2=v2w*w2
            x(i) =x(i)+u1w+v1w*bzp
            px(i)=pxi +u2 + v2*bzp
            y(i) =y(i)+wd*u2w+ws*v2w
            py(i)=pyi -wd*u1 +ws*v1
            awu=a/ws*w1
            dwu= dw*w2
            call tztafs(tz,awu,  pxi,pyi,aw1,  ws,w12, wss,g1,dz1)
            call tztafs(tz,-dwu,-pyi,pxi,aw2,-w12,ws, -wss,g2,dz2)
            z(i)=z(i)+
     $           bzp*(-((awu*dwu*dxs**2)/akkp) +
     $           ca1*pxi*pyi*wss)
     $           +dz1+dz2-aln*dv(i)
            if(n .eq. ndiv)then
              bsi(i)=-akk*(x(i)+dx0)*(y(i)+dy0)+bzp*aln*.5d0
            endif
          enddo
          alr=aln
          call tradk(np,x,px,y,py,z,gp,dv,sx,sy,sz,alr,0.d0)
          pcvt%fr0=pcvt%fr0+alr/al
        enddo
        do i=1,np
          ap=px(i)**2+py(i)**2
          dpz=sqrt1(-ap)
          r=-dpz/(1.d0+dpz)*aln*.5d0
          call xsincos(r*bzp,a24,a12,a22,a14)
          pxi=px(i)
          x(i) =x(i)+(a24*pxi-a14*py(i))/bzp
          y(i) =y(i)+(a14*pxi+a24*py(i))/bzp
          px(i)=      a22*pxi+a24*py(i)-bzp*y(i)*.5d0
          py(i)=     -a24*pxi+a22*py(i)+bzp*x(i)*.5d0
          z(i)=z(i)-(3.d0+dpz)*ap/2.d0/(2.d0+dpz)*r
        enddo
      endif
      return
      end associate
      end

max_stars_repo_name: KatsOide/SAD

max_issues_repo_name: KatsOide/SAD

max_forks_repo_name: KatsOide/SAD


text:
  function totalLinearMomentum(residual) result(totMomentum)

! ====================================================================
!
! This procedure returns the total linear momentum of a residual nucleus
!
!
! Written by CMJ, XCP-3 (03/2019)
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: real64

    implicit none
    class(GSMResidual), intent(in   ) :: residual
    real(real64)                      :: totMomentum

! ====================================================================

    totMomentum = sqrt( residual%linearMom(1)**2 + &
         & residual%linearMom(2)**2 + residual%linearMom(3)**2 )

    return
! ====================================================================
  end function totalLinearMomentum

  function totalAngularMomentum(residual) result(totMomentum)

! ====================================================================
!
! This procedure returns the total angular momentum of a residual nucleus
!
!
! Written by CMJ, XCP-3 (03/2019)
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: real64

    implicit none
    class(GSMResidual), intent(in   ) :: residual
    real(real64)                      :: totMomentum

! ====================================================================

    totMomentum = sqrt( residual%angularMom(1)**2 + &
         & residual%angularMom(2)**2 + residual%angularMom(3)**2 )

    return
! ====================================================================
  end function totalAngularMomentum

max_stars_repo_name: lanl/generalized-spallation-model

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_name: lanl/generalized-spallation-model

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_name: lanl/generalized-spallation-model

max_forks_repo_licenses: Intel Unlicense


text:
!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

! RUN: %flang -c -Knoieee %s -v 2>&1 | grep flang2 | grep "-ieee 0"
! RUN: %flang -c -Kieee %s -v 2>&1 | grep flang2 | grep "-ieee 1"
! RUN: %flang -c %s -v 2>&1 | grep flang2 | grep "-ieee 0"

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
      INTEGER FUNCTION vmec_chdir(new_path)
      IMPLICIT NONE
      CHARACTER*(*), INTENT(in) :: new_path
#if defined(CRAY)
      INTEGER :: ilen
      iLEN = 0
      CALL pxfchdir(new_path, ilen, vmec_chdir)
#else
      INTEGER :: chdir
      vmec_chdir = chdir(TRIM(new_path))
#endif
      END FUNCTION vmec_chdir

max_stars_repo_name: joseluisvelasco/STELLOPT

max_issues_repo_name: joseluisvelasco/STELLOPT

max_forks_repo_name: ORNL-Fusion/LIBSTELL


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

C=======================================================================
      SUBROUTINE MXIDEN(N,MAT)
      REAL MAT(N,*)

      IF (N .EQ. 4) THEN
        MAT(1,1) = 1.0
        MAT(1,2) = 0.0
        MAT(1,3) = 0.0
        MAT(1,4) = 0.0

        MAT(2,1) = 0.0
        MAT(2,2) = 1.0
        MAT(2,3) = 0.0
        MAT(2,4) = 0.0

        MAT(3,1) = 0.0
        MAT(3,2) = 0.0
        MAT(3,3) = 1.0
        MAT(3,4) = 0.0

        MAT(4,1) = 0.0
        MAT(4,2) = 0.0
        MAT(4,3) = 0.0
        MAT(4,4) = 1.0
      ELSE
        DO 2930 I = 1,N
          DO 2950 J = 1,N
            MAT(I,J) = 0.
 2950     CONTINUE
 2930   CONTINUE
        DO 2970 I = 1,N
          MAT(I,I) = 1.
 2970   CONTINUE
      end if
      RETURN

      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine free_convection(node1,node2,nodem,nelem,lakon,kon,
     &        ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &        nodef,idirf,df,cp,r,physcon,dvi,numf,set,shcon,
     &        nshcon,rhcon,nrhcon,ntmat_,co,vold,mi,ttime,time,
     &        iaxial,iplausi)
!
!     Free-convection-Flow
!
      implicit none
!
      logical identity
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(*),idirf(*),iflag,iaxial,
     &     ipkon(*),kon(*),mi(*),nrhcon(*),ntmat_,nshcon(*),iplausi
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),cp,r,dvi,
     &     physcon(*),co(3,*),vold(0:mi(2),*),ttime,time,
     &     shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*)
!
      intent(in) node1,node2,nodem,nelem,lakon,kon,ipkon,
     &        nactdog,ielprop,prop,iflag,v,
     &        cp,r,physcon,dvi,set,mi,
     &        ttime,time,iaxial
!
      intent(inout) identity,xflow,idirf,nodef,numf,f,df,iplausi
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif ((iflag.eq.1).or.(iflag.eq.2).or.(iflag.eq.3))then
!
!    User defined flow element
!
      endif
!
      return
      end

max_stars_repo_name: alleindrach/calculix-desktop

max_issues_repo_name: alleindrach/calculix-desktop

max_forks_repo_name: alleindrach/calculix-desktop


text:
module restart_interface

    use options_interface,  only : options_t
    use domain_interface,   only : domain_t
    use output_interface,   only : output_t

    implicit none

    interface
        module subroutine restart_model(domain, dataset, options)
            implicit none
            type(domain_t),  intent(inout) :: domain
            type(output_t),  intent(inout) :: dataset
            type(options_t), intent(inout) :: options

        end subroutine
    end interface

end module restart_interface

max_stars_repo_name: scrasmussen/icar

max_issues_repo_name: scrasmussen/icar

max_forks_repo_name: scrasmussen/icar


submodule (gemini3d_mpi) libgem_mpi_par

implicit none (type, external)

contains
  !> establish gemini process grid
  module procedure init_procgrid
    if (lid2in==-1) then
      call process_grid_auto(lx2all, lx3all)
      !! grid_size defines lx2all and lx3all
    else
      call mpi_manualgrid(lx2all, lx3all, lid2in, lid3in)
    endif
    print '(A, I0, A1, I0)', 'process grid (Number MPI processes) x2, x3:  ',mpi_cfg%lid2, ' ', mpi_cfg%lid3
    print '(A, I0, A, I0, A1, I0)', 'Process:',mpi_cfg%myid,' at process grid location: ',mpi_cfg%myid2,' ',mpi_cfg%myid3
  end procedure init_procgrid
end submodule libgem_mpi_par


module fftw_module

  use,intrinsic :: iso_c_binding
  use grid_module, only: grid, get_range_rgrid, mpi_allgatherv_grid, get_map_3d_to_1d_grid
  use rsdft_mpi_module, only: rsdft_allgatherv

  implicit none

  private
  public :: init_fftw
  public :: finalize_fftw
  public :: plan_forward, plan_backward
  public :: ML1_c, ML2_c, N_ML3_c, ML3_c0
  public :: zwork3_ptr0, zwork3_ptr1
  public :: d1_to_z3_fftw
  public :: z3_to_d1_fftw
  public :: z3_to_z1_fftw
  public :: forward_fftw
  public :: backward_fftw
  public :: forward_2d_fftw

  integer :: comm_fftw
  type(c_ptr) :: plan_forward,plan_backward
  type(c_ptr) :: zwork3_cptr0,zwork3_cptr1
  integer(c_intptr_t) :: ML1_c,ML2_c,ML3_c,ML3_c0,N_ML3_c
  complex(c_double_complex), pointer :: zwork3_ptr0(:,:,:)=>null()
  complex(c_double_complex), pointer :: zwork3_ptr1(:,:,:)=>null()

  integer,allocatable :: ir(:),id(:)

  integer(8) :: plan_2d_forward
  integer :: size_2d(2)=(/0,0/)

  logical :: flag_init_fftw=.false.

contains

  SUBROUTINE init_fftw( Ngrid, Np, comm_grid, myrank_g )

    implicit none
    integer,intent(IN) :: Ngrid(3),Np(3),comm_grid, myrank_g
#ifdef _FFTW_
    integer :: ML1,Ml2,ML3,np1,np2,np3,n,m
    integer :: i1,i2,i3,irank,icolor,ierr
    integer(c_intptr_t) :: alloc_ML3_c
    include "fftw3-mpi.f03"
    include "mpif.h"

    call write_border( 0, " init_fftw(start)" )

    ML1 = Ngrid(1)
    ML2 = Ngrid(2)
    ML3 = Ngrid(3)
    np1 = Np(1)
    np2 = Np(2)
    np3 = Np(3)

    if ( mod(ML3,np3) /= 0 ) then
      call stop_program( "fftw_init: mod(ML3,np3)/=0 is not supported." )
    end if

    irank=-1
    do i3=1,np3
    do i2=1,np2
    do i1=1,np1
      irank=irank+1
      if ( irank == myrank_g ) icolor=i1+(i2-1)*np1
    end do
    end do
    end do

    call mpi_comm_split(comm_grid,icolor,0,comm_fftw,ierr)

    call fftw_mpi_init()

    ML1_c = ML1
    ML2_c = ML2
    ML3_c = ML3

    alloc_ML3_c = &
         fftw_mpi_local_size_3d(ML3_c,ML2_c,ML1_c,comm_fftw,N_ML3_c,ML3_c0)
    zwork3_cptr0=fftw_alloc_complex(alloc_ML3_c)
    zwork3_cptr1=fftw_alloc_complex(alloc_ML3_c)
    call c_f_pointer(zwork3_cptr0, zwork3_ptr0, [ML1_c,ML2_c,N_ML3_c])
    call c_f_pointer(zwork3_cptr1, zwork3_ptr1, [ML1_c,ML2_c,N_ML3_c])
    zwork3_ptr0=(0.0d0,0.0d0)
    zwork3_ptr1=(0.0d0,0.0d0)

    plan_forward  = fftw_mpi_plan_dft_3d( ML3_c,ML2_c,ML1_c &
         ,zwork3_ptr0,zwork3_ptr1,comm_fftw,fftw_forward,fftw_measure )

    plan_backward = fftw_mpi_plan_dft_3d( ML3_c,ML2_c,ML1_c &
         ,zwork3_ptr0,zwork3_ptr1,comm_fftw,fftw_backward,fftw_measure )

    call mpi_comm_size( comm_fftw, n, ierr )
    call mpi_comm_rank( comm_fftw, m, ierr )
    allocate( ir(0:n-1) ) ; ir=0
    allocate( id(0:n-1) ) ; id=0
!    m=ML1*ML2
!    call mpi_allgather(m*N_ML3_c,1,MPI_INTEGER,ir,1,MPI_INTEGER,comm_fftw,ierr)
!    call mpi_allgather(m*ML3_c0 ,1,MPI_INTEGER,id,1,MPI_INTEGER,comm_fftw,ierr)
    i1 = ML1*ML2*N_ML3_c
    i2 = ML1*ML2*ML3_c0
    call mpi_allgather(i1,1,MPI_INTEGER,ir,1,MPI_INTEGER,comm_fftw,ierr)
    call mpi_allgather(i2,1,MPI_INTEGER,id,1,MPI_INTEGER,comm_fftw,ierr)

    flag_init_fftw=.true.

    call write_border( 0, " init_fftw(end)" )
#endif
  END SUBROUTINE init_fftw

  SUBROUTINE finalize_fftw
#ifdef _FFTW_
    implicit none
    integer :: ierr
    include "fftw3-mpi.f03"
    if ( .not.flag_init_fftw ) return
    call mpi_comm_free(comm_fftw,ierr)
    call fftw_destroy_plan(plan_forward)
    call fftw_destroy_plan(plan_backward)
    call fftw_free(zwork3_cptr0)
    call fftw_free(zwork3_cptr1)
    call fftw_mpi_cleanup()
#endif
  END SUBROUTINE finalize_fftw

  subroutine d1_to_z3_fftw( d1, z3 )
    implicit none
    real(8),intent(in) :: d1(:)
    complex(8),intent(out) :: z3(:,:,:)
    integer :: i1,i2,i3
    type(grid) :: rgrid
    real(8),allocatable :: work(:)
    integer,allocatable :: LLL(:,:,:)
    call get_range_rgrid( rgrid )
    allocate( work(rgrid%g1%size_global) ); work=0.0d0
    call mpi_allgatherv_grid( d1, work )
    call get_map_3d_to_1d_grid( rgrid, LLL )
    do i3=1,N_ML3_c
    do i2=1,ML2_c
    do i1=1,ML1_c
      z3(i1,i2,i3) = work( LLL(i1-1,i2-1,i3-1+ML3_c0) )
    end do
    end do
    end do
    deallocate( LLL )
    deallocate( work )
  end subroutine d1_to_z3_fftw

  subroutine z3_to_d1_fftw( z3, d1 )
    implicit none
    complex(8),intent(in) :: z3(:,:,:)
    real(8),intent(out) :: d1(:)
    integer :: i1,i2,i3,i
    type(grid) :: rgrid
    call get_range_rgrid( rgrid )
    i=0
    do i3=1,N_ML3_c
    do i2=rgrid%g3%y%head+1,rgrid%g3%y%tail+1
    do i1=rgrid%g3%x%head+1,rgrid%g3%x%tail+1
       i=i+1
       d1(i) = dble( z3(i1,i2,i3) )
    end do
    end do
    end do
  end subroutine z3_to_d1_fftw

  SUBROUTINE z3_to_z1_fftw( z3, z1 )
    implicit none
    complex(8),intent(IN) :: z3(:,:,:)
    complex(8),intent(OUT) :: z1(:)
    integer :: i1,i2,i3,i
    type(grid) :: rgrid
    call get_range_rgrid( rgrid )
    i=0
    do i3=1,N_ML3_c
    do i2=rgrid%g3%y%head+1,rgrid%g3%y%tail+1
    do i1=rgrid%g3%x%head+1,rgrid%g3%x%tail+1
       i=i+1
       z1(i) = z3(i1,i2,i3)
    end do
    end do
    end do
  END SUBROUTINE z3_to_z1_fftw

  SUBROUTINE forward_fftw( z3 )
    implicit none
    complex(8),intent(INOUT) :: z3(:,:,:)
    integer :: i1,i2,i3,j3
    real(8) :: const
#ifdef _FFTW_
    include "fftw3-mpi.f03"
    do i3=1,N_ML3_c
       j3=i3+ML3_c0
       do i2=1,ML2_c
       do i1=1,ML1_c
          zwork3_ptr0(i1,i2,i3) = z3(i1,i2,j3)
       end do
       end do
    end do
    call fftw_mpi_execute_dft( plan_forward, zwork3_ptr0, zwork3_ptr1 )
    call rsdft_allgatherv( zwork3_ptr1, z3, ir, id, comm_fftw )
    const=1.0d0/size(z3)
    z3(:,:,:)=const*z3(:,:,:)
#endif
  END SUBROUTINE forward_fftw

  SUBROUTINE backward_fftw( z3 )
    implicit none
    complex(8),intent(INOUT) :: z3(:,:,:)
    integer :: i1,i2,i3,j3
    real(8) :: const
#ifdef _FFTW_
    include "fftw3-mpi.f03"
    do i3=1,N_ML3_c
       j3=i3+ML3_c0
       do i2=1,ML2_c
       do i1=1,ML1_c
          zwork3_ptr0(i1,i2,i3) = z3(i1,i2,j3)
       end do
       end do
    end do
    call fftw_mpi_execute_dft( plan_backward, zwork3_ptr0, zwork3_ptr1 )
    call rsdft_allgatherv( zwork3_ptr1, z3, ir, id, comm_fftw )
    !const=1.0d0/size(z3)
    !z3(:,:,:)=const*z3(:,:,:)
#endif
  END SUBROUTINE backward_fftw

  SUBROUTINE forward_2d_fftw( z2, zw )
    implicit none
    complex(8),intent(INOUT) :: z2(:,:), zw(:,:)
    integer :: m1,m2
    real(8) :: const
#ifdef _FFTW_
    include 'fftw3.f'
    m1 = size( z2, 1 )
    m2 = size( z2, 2 )
    if ( size_2d(1) /= m1 .or. size_2d(2) /= m2 ) then
       call dfftw_plan_dft_2d( plan_2d_forward, m1, m2, z2, z2 &
            , FFTW_FORWARD, FFTW_ESTIMATE )
       size_2d(:) = (/ m1, m2 /)
    end if
    call dfftw_execute_dft( plan_2d_forward, z2, zw )
    const=1.0d0/size(z2)
    z2(:,:)=const*zw(:,:)
#endif
  END SUBROUTINE forward_2d_fftw

END MODULE fftw_module


text:
subroutine fcho_solve(A,y,x)

    implicit none

    double precision, dimension(:,:), intent(in) :: A
    double precision, dimension(:), intent(in) :: y
    double precision, dimension(:), intent(inout) :: x

    integer :: info, na

    na = size(A, dim=1)

    call dpotrf("U", na, A, na, info)
    call dpotrs("U", na, 1, A, na, y, na, info)

    x(:na) = y(:na)

end subroutine fcho_solve

max_stars_repo_name: andersx/cholesky-py-mkl-parallel

max_issues_repo_name: andersx/cholesky-py-mkl-parallel

max_forks_repo_name: andersx/cholesky-py-mkl-parallel


text:
! Created by EverLookNeverSee@GitHub on 5/25/20.
! This program sorts a sequence in ascending order.

program aas
    implicit none
    ! declaring variables
    integer :: n, i, j
    real :: temp
    real, allocatable, dimension(:) :: sequence
    ! getting user input in order to specify number of elements in sequence.
    n = -1
    do
        print *, "Enter the number of elements in the sequence:"
        read *, n
        if (n > 0) exit
    end do
    ! allocating memory for array
    allocate(sequence(n))
    ! getting elements of sequence from user input
    do i = 1, n
        print *, "Element number", i, "is:"
        read *, sequence(i)
    end do
    ! Compare two elements sequence(i) and sequence(j) (i < j).
    ! If a i > a j swap the two elements.
    do i = 1, n - 1
        do j = i + 1, n
            if (sequence(i) > sequence(j)) then
                temp = sequence(j)
                sequence(j) = sequence(i)
                sequence(i) = temp
            end if
        end do
    end do
    ! printing sorted sequence.
    print *, sequence
end program aas

max_stars_repo_name: EverLookNeverSee/FCS

max_issues_repo_name: EverLookNeverSee/FCS

max_forks_repo_name: EverLookNeverSee/FCS


module utils

Integer, Parameter :: kdp = selected_real_kind(15)
public :: find,utm_geo,sort_rows,erasedupli
private :: kdp

private :: find_1dI,find_1dR, find_2d ,find_2dI

interface find
         module procedure find_1dI,find_1dR, find_2dR,find_2dI
end interface

contains

!=================================================
! arrange array 'a' in ascending order
subroutine sort_rows(a,n,m)
implicit none
integer,intent(in) :: n,m
integer, dimension(n,m),intent(inout) :: a
integer, dimension(n,m) :: a_dummy
integer, dimension(n) :: idx
integer :: i

a_dummy = a

do i = 1,n
! descending order
  idx(i) = minloc(a_dummy(:,1),1)
  a_dummy(idx(i),1) = maxval(a_dummy(:,1),1)+1
enddo

a = a(idx,:)

end subroutine sort_rows

!========================================================
subroutine find_1dR(array,condt,target_value,idx)
implicit none
real,dimension(:),intent(in) :: array
integer,allocatable,dimension(:), intent(out) :: idx
integer,allocatable,dimension(:) :: loc
character(2),intent(in) :: condt
integer :: i,n,target_value,inx

n = size(array)
allocate(loc(n))
loc = 0
inx = 0
if (condt == '==') then
       do i = 1,n
              if(array(i) == target_value) then
                     inx = inx+1
                     loc(inx) = i
              endif
       enddo
else
       do i = 1,n
              if(array(i) /= target_value) then
                     inx = inx+1
                     loc(inx) = i
              endif
       enddo
endif

if (inx > 0) then  ! target_value is in array
	allocate(idx(inx))
	idx = loc(1:inx)
else   ! target_value is not in array
	allocate(idx(1))
	idx = -1

endif
deallocate(loc)

return

end subroutine find_1dR
!========================================================
!========================================================
subroutine find_1dI(array,condt,target_value,idx)
implicit none
integer,dimension(:),intent(in) :: array
integer,allocatable,dimension(:), intent(out) :: idx
integer,allocatable,dimension(:) :: loc
integer :: i,n,target_value,inx
character(2),intent(in) :: condt

n = size(array,1)
allocate(loc(n))
loc = 0
inx = 0

if (condt == '==') then
       do i = 1,n
              if(array(i) == target_value) then
                     inx = inx+1
                     loc(inx) = i
              endif
       enddo
else
       do i = 1,n
              if(array(i) /= target_value) then
                     inx = inx+1
                     loc(inx) = i
              endif
       enddo
endif

if (inx > 0) then  ! target_value is in array
	allocate(idx(inx))
	idx = loc(1:inx)
else   ! target_value is not in array
	allocate(idx(1))
	idx = -1 !loc(1)

endif
deallocate(loc)

return

end subroutine find_1dI
!========================================================
subroutine find_2dR(array,condt,target_value,idx,jdx)
implicit none
real,dimension(:,:),intent(in) :: array
integer,allocatable,dimension(:), intent(out) :: idx,jdx
integer,allocatable,dimension(:) :: loc_i,loc_j
real :: target_value
integer :: i,j,n,m,inx
character(2),intent(in) :: condt

n = size(array,1)
m = size(array,2)

allocate(loc_i(n*m),loc_j(n*m))

loc_i(:) = 0
loc_j(:) = 0

inx = 0
if (condt == '==') then
       do j = 1,m
              do i = 1,n
                     if(array(i,j) == target_value) then
                            inx = inx+1
                            loc_i(inx) = i
                            loc_j(inx) = j
                     endif
              enddo
       enddo
else
       do j = 1,m
              do i = 1,n
                     if(array(i,j) /= target_value) then
                            inx = inx+1
                            loc_i(inx) = i
                            loc_j(inx) = j
                     endif
              enddo
       enddo
endif

if (inx > 0) then  ! target_value is in array
	allocate(idx(inx))
	idx = loc_i(1:inx)

	allocate(jdx(inx))
	jdx = loc_j(1:inx)

else   ! target_value is not in array
	allocate(idx(1))
	idx = -1

	allocate(jdx(1))
	jdx = -1

endif
deallocate(loc_i,loc_j)

return
end subroutine find_2dR
!========================================================
!========================================================
subroutine find_2dI(array,condt,target_value,idx,jdx)
implicit none
integer,dimension(:,:),intent(in) :: array
integer,allocatable,dimension(:), intent(out) :: idx,jdx
integer,allocatable,dimension(:) :: loc_i,loc_j
integer :: i,j,n,m,target_value,inx
character(2),intent(in) :: condt

n = size(array,1)
m = size(array,2)

allocate(loc_i(n*m),loc_j(n*m))

loc_i(:) = 0
loc_j(:) = 0

inx = 0
if (condt == '==') then
       do j = 1,m
              do i = 1,n
                     if(array(i,j) == target_value) then
                            inx = inx+1
                            loc_i(inx) = i
                            loc_j(inx) = j
                     endif
              enddo
       enddo
else
       do j = 1,m
              do i = 1,n
                     if(array(i,j) /= target_value) then
                            inx = inx+1
                            loc_i(inx) = i
                            loc_j(inx) = j
                     endif
              enddo
       enddo
endif

if (inx > 0) then  ! target_value is in array
	allocate(idx(inx))
	idx = loc_i(1:inx)

	allocate(jdx(inx))
	jdx = loc_j(1:inx)

else   ! target_value is not in array
	allocate(idx(1))
	idx = -1 !

	allocate(jdx(1))
	jdx = -1

endif
deallocate(loc_i,loc_j)

return
end subroutine find_2dI
!========================================================
subroutine erasedupli(val,nv,nnv)
! erase duplicates from vector val
   integer :: nv,nnv
   integer, dimension(nv) :: val
   logical, dimension(nv) :: dp
   integer :: i,j

   dp=.false.
   do i=1,nv-1
      if (val(i) == 0) dp(i)=.true.
      if (dp(i)) cycle
      do j=i+1,nv
         if (.not.dp(j)) dp(j)=(val(i) == val(j))
      enddo
   enddo

   i=1
   nnv=nv
   do while (i <= nnv)
      if (dp(i)) then
         do j=i,nnv-1
            val(j)=val(j+1)
            dp(j)=dp(j+1)
         enddo
         nnv=nnv-1
      else
         i=i+1
      endif
   enddo

   return
end subroutine erasedupli
!========================================================

end module utils


PROGRAM QA4
! (LICENSE:Public Domain)
   USE M_calcomp
   ! 07/30/69
   DIMENSION X(104), Y(104)
   CHARACTER*40 MSG
   EQUIVALENCE(X(1),XL),(Y(1),YL)
9001 FORMAT(2(1X,I2,7X),A40)
9007 FORMAT(7(1X,F9.3),F7.1)
9009 FORMAT(2(1X,F9.3),1X,I3,7X,I1)
9012 FORMAT(7(1X,F9.3),1X,I1)
9014 FORMAT(4(1X,F9.3),2(1X,I2,7X))
9016 FORMAT(3(1X,F9.3), A40,1X,I3)
9017 FORMAT(1X,F9.3,1X,I2)
9021 FORMAT(5(1X,F9.3),1X,I2)
!
   call make_c_qa4()   ! create datafile
   KIN = 50
   F = 1.0
   IPN = 2
   CALL PLOTS(0.0,8.5,0.0,11.0)
!-----------------------------------------------------------------------
   open(unit=kin,file='qa4.dat')
1  CONTINUE
   READ(KIN,9001) KLAS,NREC, MSG
   IF(KLAS) 1,100,40
40 GOTO (200,300,400,500,600,700,800,900,1000,1100,1200,1, 1400,1500,1) , KLAS
!-----------------------------------------------------------------------
100 continue
   DO I = 1,NREC
      READ(KIN,9007) X(1),Y(1),X(2),Y(2),X(3),Y(3),X(4),Y(4)
      DO J = 1,4
         IF(X(J)) 140,120,140
120      IF(Y(J)) 140,130,140
130      IPN = 3
         cycle
140      CALL PLOT(X(J),Y(J),IPN)
         IPN = 2
      enddo
   enddo
   GOTO 1
!-----------------------------------------------------------------------
200 continue
   DO I = 1,NREC
      READ(KIN,9007) XL,YL,THO,THF,RO,RF,DI
      CALL CIRCL(XL,YL,THO,THF,RO,RF,DI)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
300 continue
   DO I = 1,NREC
      READ(KIN,9009) X(1),Y(1),NPTS,INC
      J1 = INC+1
      J2 = INC*NPTS+1-INC
      DO J = J1,J2,INC
         READ(KIN,9007) X(J),Y(J)
      enddo
      J = J2+INC
      X(J) = 0.
      Y(J) = 0.
      J = J+INC
      X(J) = 1.
      Y(J) = 1.
      CALL DASHL(X,Y,NPTS,INC)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
400 continue
   DO I = 1,NREC
      READ(KIN,9007) XL,YL,D
      CALL DASHP(XL,YL,D)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
500 continue
   DO I = 1,NREC
      READ(KIN,9012) XL,YL,RMA,RMI,A,TH0,THF,IPEN
      CALL ELIPS(XL,YL,RMA,RMI,A,THO,THF,IPEN)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
600 continue
   DO I = 1,NREC
      READ(KIN,9007) X(1),Y(1),X(2),Y(2),X(3),Y(3)
      CALL FIT(X(1),Y(1),X(2),Y(2),X(3),Y(3))
   enddo
   GOTO 1
!-----------------------------------------------------------------------
700 continue
   DO I = 1,NREC
      READ(KIN,9014) XL,YL,DX,DY,NX,NY
      CALL GRID(XL,YL,DX,DY,NX,NY)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
800 continue
   DO I = 1,NREC
      READ(KIN,9007) XL,YL,SL,SN,A
      CALL POLY(XL,YL,SL,SN,A)
   ENDDO
   GOTO 1
!-----------------------------------------------------------------------
900 continue
   DO I = 1,NREC
      READ(KIN,9021) XL,YL,H,W,A,IPEN
      CALL RECT(XL,YL,H,W,A,IPEN)
   ENDDO
   GOTO 1
!-----------------------------------------------------------------------
1000 continue
   DO I = 1,NREC
      READ(KIN,9016) XL,YL,H,MSG,INC
      READ(KIN,9017) A,NC
      IF(INC) 1,1030,1040
1040  CONTINUE
1030  CONTINUE
      CALL SYMBOL(XL,YL,H,MSG,INC,A,NC)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
1100 continue
   DO I = 1,NREC
      READ(KIN,9007) XL,YL
      CALL PLOT(XL,YL,-3)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
1200 continue
   DO I = 1,NREC
      READ(KIN,9007) F
      CALL FACTOR(F)
   enddo
   GOTO 1
!-----------------------------------------------------------------------
1400 continue
   CALL FACTOR(1.)
   CALL PLOT(20.,0.,999)
   STOP
!-----------------------------------------------------------------------
1500 continue
   DO I = 1,NREC
   ENDDO
   GOTO 1
!-----------------------------------------------------------------------
contains

   subroutine make_c_qa4()
      integer,parameter :: io=40
      open(unit=io,file='qa4.dat')
      write(io,'(a)')'  8         1                RECT'
      write(io,'(a)')' 1.        1.        9.         7.       0.         3'
      write(io,'(a)')'  9         7                SYMBOL'
      write(io,'(a)')' 1.5       9.5       .14      SAMPLE OF GENERAL SUBROUTINES PACKAGE    999'
      write(io,'(a)')' 0.        37'
      write(io,'(a)')' 2.25      9.        .105     CIRCL                                    999'
      write(io,'(a)')' 0.         6'
      write(io,'(a)')' 5.75      9.        .105     ELIPS                                    999'
      write(io,'(a)')' 0.         5'
      write(io,'(a)')' 2.25      6.5       .105     FIT, DASHP                               999'
      write(io,'(a)')' 0.        11'
      write(io,'(a)')' 5.75      6.5       .105     POLY                                     999'
      write(io,'(a)')' 0.         4'
      write(io,'(a)')' 3.75      4.25      .105     GRID, DASHL                              999'
      write(io,'(a)')' 0.        12'
      write(io,'(a)')' 2.        1.1       .07      THE BORDER IS DRAWN WITH RECT            999'
      write(io,'(a)')' 0.        29'
      write(io,'(a)')'  1         3                CIRCL'
      write(io,'(a)')' 3.25      8.        0.        720.      .75       .25       0.'
      write(io,'(a)')' 3.25      8.        0.        360.      .75       .25       1.'
      write(io,'(a)')' 3.35      8.        0.        360.      .85       .85       0.'
      write(io,'(a)')'  4         6                ELIPS'
      write(io,'(a)')' 6.5       8.        .5        .7        0.        0.        360.      3'
      write(io,'(a)')' 6.6       8.        .6        .6        0.        0.        360.      3'
      write(io,'(a)')' 6.7       8.        .7        .5        0.        0.        360.      3'
      write(io,'(a)')' 6.8       8.        .8        .4        0.        0.        360.      3'
      write(io,'(a)')' 6.9       8.        .9        .3        0.        0.        360.      3'
      write(io,'(a)')' 7.        8.        1.        .2        0.        0.        360.      3'
      write(io,'(a)')'            3                DATA'
      write(io,'(a)')' 0.        0.        1.5       5.        1.5       5.5       2.375     6.'
      write(io,'(a)')' 3.5       6.125     2.625     5.5       1.5       5.5       0.        0.'
      write(io,'(a)')' 1.5       5.        2.625     5.        3.5       5.625     0.        0.'
      write(io,'(a)')'  3         1                  DASHP'
      write(io,'(a)')' 2.375     5.625     .1'
      write(io,'(a)')'            1                  DATA'
      write(io,'(a)')' 1.5       5.        1.5       5.        1.5       5.        0.       0'
      write(io,'(a)')'  3         2                  DASHP'
      write(io,'(a)')' 2.375     5.625     .1'
      write(io,'(a)')' 2.375     6.125     .1'
      write(io,'(a)')'  5         2                FIT'
      write(io,'(a)')' 2.625     5.        2.5       5.25      2.625     5.5'
      write(io,'(a)')' 3.5       5.625     3.375     5.875     3.5       6.125'
      write(io,'(a)')'  7        10                  POLY'
      write(io,'(a)')' 5.75      5.        .35       3.        0.'
      write(io,'(a)')' 5.75      5.        .35       4.        0.'
      write(io,'(a)')' 5.75      5.        .35       5.        0.'
      write(io,'(a)')' 5.75      5.        .35       6.        0.'
      write(io,'(a)')' 5.75      5.        .35       7.        0.'
      write(io,'(a)')' 5.75      5.        .35       8.        0.'
      write(io,'(a)')' 5.75      5.        .35       9.        0.'
      write(io,'(a)')' 5.75      5.        .35       10.       0.'
      write(io,'(a)')' 5.75      5.        .35       11.       0.'
      write(io,'(a)')' 5.75      5.        .35       12.       0.'
      write(io,'(a)')'  6         2                GRID'
      write(io,'(a)')' 1.5       2.        .25       .25       24         8'
      write(io,'(a)')' 1.51      1.99      1.5       1.         4         2'
      write(io,'(a)')'  2         1                DASHL'
      write(io,'(a)')' 1.75      2.25       11       1'
      write(io,'(a)')' 2.5       3.75'
      write(io,'(a)')' 2.75      3.25'
      write(io,'(a)')' 3.        3.5'
      write(io,'(a)')' 3.5       2.75'
      write(io,'(a)')' 4.        2.5'
      write(io,'(a)')' 4.25      3.25'
      write(io,'(a)')' 5.25      2.75'
      write(io,'(a)')' 5.5       3.75'
      write(io,'(a)')' 6.5       2.5'
      write(io,'(a)')' 7.25      3.5'
      write(io,'(a)')' 13                           END'
      close(unit=io)
   end subroutine make_c_qa4

END PROGRAM QA4


text: Want to know what is going on in the world of Kai SavareeRuess Kai?  Email me at MailTo(kairuess AT ucdavis DOT edu) and Ill hit you back.  Have a great frickin day!


text:
#version 130
out vec4 machuchu_FragColor;

in vec2 p;
uniform float time;

uniform bool draw_dots;
uniform bool draw_borders; // looks ok if ether rank1 or rank2 is zero

uniform int rank1 = 6, rank2 = 7;
uniform int rotate_speed1 = 10, rotate_speed2 = -5;
uniform int zoom_speed1 = 0, zoom_speed2 = 0;
#pragma machuchu slider rank1 2 10
#pragma machuchu slider rank2 2 10
#pragma machuchu slider rotate_speed1 -100 100
#pragma machuchu slider rotate_speed2 -100 100
#pragma machuchu slider zoom_speed1 -100 100
#pragma machuchu slider zoom_speed2 -100 100

#include "color.h"

#define POINT_SIZE 0.0002
uniform bool DEBUG_RINGS;

float res_d = 1./0.;
vec3 res_color = vec3(0);
bool in_border = false;
int debug_rings = 0;

void add_point(vec2 pos, vec3 color) {
    float distance_from_center = length2(p);
    float d = length2(pos - p);
    if(res_d < d)
        return;

    if (draw_borders &&
        res_d != 1./0. &&
        (res_d - d) / distance_from_center < 0.1)
        in_border = true;

    res_d = d;

    float shade = draw_dots && d < distance_from_center * POINT_SIZE
        ? 0.8
        : atan(distance_from_center / d / 2.) / PI * 2.;

    if (in_border)
        shade *= 0.5;

    res_color = color * shade;
}

void endless(int rank, float ring_dist, float zoom, float rotation, float sat) {
    if(rank <= 2) return;
    if(ring_dist == 0.)
        ring_dist = (1. + sin(PI / float(rank))) / cos(PI / float(rank));
    zoom *= float(rank);

    int center_ring = int(floor(log(length2(p)) / 2. / log(ring_dist) - zoom));
    float alpha = (atan(p.y, p.x)/TAU - rotation) * float(rank);
    float alpha1 = floor(alpha+0.5) / float(rank);
    float alpha2 = floor(alpha) / float(rank);

    debug_rings += center_ring;
    for(int ring = center_ring-1; ring <= center_ring+1; ring++) {
        float shift = float(abs(ring) % 2) / 2. / float(rank);
        float color_shift = float(idiv(3*ring, 2)) / float(rank);
        float d = abs(ring)%2 == 0? alpha1 : alpha2;
        float t = (rotation + shift + d)*TAU;
        vec2 pos = pow(ring_dist, float(ring) + zoom) * vec2(cos(t), sin(t));
        add_point(pos, hsv2rgb(d+color_shift,sat, 1.));
    }
}

void main() {
    float rot = time/1000000.;
    float zoom = time/100000.;
    endless(rank1, 0., zoom*float(zoom_speed1), rot*float(rotate_speed1), 1.0);
    endless(rank2, 0., zoom*float(zoom_speed2), rot*float(rotate_speed2), 0.5);

    float shade = 1.;
    if (DEBUG_RINGS)
        shade *= float(debug_rings % 2) / 2. + 0.5;

    machuchu_FragColor = vec4(res_color, 1) * shade;
}

max_stars_repo_name: hedlx/machuchu

max_issues_repo_name: hedlx/machuchu

max_forks_repo_name: hedlx/machuchu


text:
   program create_wb_hdf
!=======================================================================
!
!  Program to create an VERA HDF file using user supplied data
!
!  Geometry information is hard-wired for the WB reactor.
!  This information is set in the module "Mod_geom"
!
!  State information is hard-wired in module "Mod_state"
!  This information should be updated every statepoint from user data
!
!  Dependencies:  This program uses the HDF data library that can be
!  downloaded from: https://hdfgroup.org/
!
!  Scott Palmtag
!  August 18, 2021
!
!=======================================================================
      use hdf5
      use mod_geom,  only : npin, maxasm, kdfuel
      use mod_state, only : mem_state
      implicit none

      character(len=100) :: hdfname   ! HDF output file name
      character(len=256) :: powfile   ! input file containing pin powers

      integer :: ierror    ! error code
      integer :: ista      ! statepoint number
      integer :: iout      ! output unit number

      integer :: k

      integer :: maxsta=1  ! ***** only write one state for now

      logical :: ifxst     ! logical to check if input file exists

!--- hdf data

      integer(hid_t) :: file_id  ! HDF File identifier

!--- initialize

      powfile='power.inp'
      hdfname='output.h5'
      iout=8

!--- read command line

      k=iargc()
      if (k.eq.0) then
        stop 'usage: reader [powfile] {h5 file}'
      endif
      if (k.ge.1) then
        call getarg(1,powfile)
      endif
      if (k.ge.2) then
        call getarg(2,hdfname)
      else
        hdfname=trim(powfile)//'.h5'
      endif

      if (powfile.eq.hdfname) stop 'input and output file names cannot be the same'

!--- allocate memory for pin distributions

      call mem_state(npin, maxasm, kdfuel)

!--- Open text input file

      inquire (file=powfile,exist=ifxst)
      if (.not.ifxst) then
        write (*,'(2a)') 'reading: ', trim(powfile)
        stop 'powfile is not found'
      endif

!-----------------------------------------
!  Create HDF file and write CORE block
!-----------------------------------------

      call write_hdf_core(hdfname, file_id, iout)

!-----------------------------------------
!  Read user data
!-----------------------------------------

      call readpow(powfile)

!-------------------------
!  Write statepoints
!-------------------------

!--- write statepoint data to HDF file

      do ista=1, maxsta

        call write_hdf_state(file_id, ista, iout)

      enddo

!--- close HDF file

      call h5fclose_f(file_id, ierror)

      write (0,*)    'finished'
      write (iout,*) 'finished'

      end program create_wb_hdf

!=======================================================================
!
!  Read user data from file
!
!=======================================================================
      subroutine readpow(powfile)
      use mod_state
      implicit none

      character(len=*), intent(in) :: powfile   ! input file name

      character(len=200) :: line
      character(len=10)  :: key
      integer :: na, i, j, k

      pinpow=0.0d0

      open(81,file=powfile,status='old',action='read')

      do
        read (81,'(a)',end=100) line
        if (line.eq.' ') cycle   ! skip blank line
        read (line,*) key        ! read first keyword, might be a number
        if     (key.eq.'boron') then
           read (line,*) key, boron
        elseif (key.eq.'keff') then
           read (line,*) key, xkeff
        elseif (key.eq.'power') then
           read (line,*) key, power
        elseif (key.eq.'flow') then
           read (line,*) key, flow
        elseif (key.eq.'efpd') then
           read (line,*) key, efpd
        elseif (key.eq.'exposure') then
           read (line,*) key, ave_exp
        else          ! read power
          read (line,*) na, k, i, j, pinpow(na,k,i,j)
        endif
      enddo
  100 continue

      close (81)

! ???? check normalization

      return
      end subroutine readpow

max_stars_repo_name: palmtag/VERAout-tools

max_issues_repo_name: palmtag/VERAout-tools

max_forks_repo_name: palmtag/VERAout-tools


text:
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_differentiate
CONTAINS
  REAL FUNCTION difcub(x,f,xi)
    !     **********************************************************
    !     differentiate the function f, given at the
    !     points x0,x1,x2,x3 at the point xi by lagrange
    !     interpolation for polynomial of 3rd order
    !     r.p.
    !     ***********************************************************
    IMPLICIT NONE
    !     .. Scalar Arguments ..
    REAL,INTENT(IN):: xi
    !     ..
    !     .. Array Arguments ..
    REAL,INTENT(IN):: f(0:3),x(0:3)
    !     ..
    difcub = ((xi-x(1))* (xi-x(2))+ (xi-x(1))* (xi-x(3))+&
         (xi-x(2))* (xi-x(3)))*f(0)/ ((x(0)-x(1))* (x(0)-x(2))*&
         (x(0)-x(3))) + ((xi-x(0))* (xi-x(2))+&
         (xi-x(0))* (xi-x(3))+ (xi-x(2))* (xi-x(3)))*f(1)/&
         ((x(1)-x(0))* (x(1)-x(2))* (x(1)-x(3))) +&
         ((xi-x(0))* (xi-x(1))+ (xi-x(0))* (xi-x(3))+&
         (xi-x(1))* (xi-x(3)))*f(2)/ ((x(2)-x(0))* (x(2)-x(1))*&
         (x(2)-x(3))) + ((xi-x(0))* (xi-x(1))+&
         (xi-x(0))* (xi-x(2))+ (xi-x(1))* (xi-x(2)))*f(3)/&
         ((x(3)-x(0))* (x(3)-x(1))* (x(3)-x(2)))
    RETURN
  END FUNCTION difcub
  SUBROUTINE diff3(&
       f,dx,&
       df)
    !********************************************************************
    !     differetiation via 3-points
    !********************************************************************

    IMPLICIT NONE

    !     .. Scalar Arguments ..
    REAL,    INTENT (IN) :: dx
    !     ..
    !     .. Array Arguments ..
    REAL, INTENT (IN)  ::  f(:)
    REAL, INTENT (OUT) :: df(:)
    !     ..
    !     .. Local Scalars ..
    INTEGER i,jri
    REAL tdx_i
    !     ..
    jri=size(f)
    tdx_i = 1./(2.*dx)
    !
    !---> first point
    df(1) = -tdx_i * (-3.*f(1)+4.*f(2)-f(3))
    !
    !---> central point formula in charge
    DO i = 2,jri - 1
       df(i) = tdx_i * (f(i+1)-f(i-1))
    END DO
    !
    !---> last point
    df(jri) = tdx_i * (3.*f(jri)-4.*f(jri-1)+f(jri-2))
    !
    RETURN
  END SUBROUTINE diff3

END MODULE m_differentiate

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
Talara Hall is a part of the Regan Residence Halls in Segundo Residence Halls Segundo.

Like many of the Regan Residence Halls Talara was themed the Quiet Dorm with quiet hours beginning at an earlier time than other buildings, but it is rumored that it changed to a nonthemed community in the 20112012 academic year due to Bradley Bottoms (known extrovert) being assigned to Talara.

Note to prospective students  the quiet dorm, at least when I was there (1998), was basically a joke, as half the students in the dorm were there because their parents forced them, and they had no actual interest in being quiet (I would assume similar applies to some of the other theme dorms). We were regularly serenaded by people drunkenly singing The Star Spangled Banner in the shower at 3:00AM, just like any other dorm. I suppose the effectiveness of the theme dorms depends largely on the effectiveness of the RA, but doing it over again, I wouldnt bother with the quiet dorm. Users/JessicaLuedtke

The Long History and Legacy of Talara Hall 20112012:
Floor plan/setup:
	During this year, the first two floors were coed, but the third floor was an all female floor. The first and third floors have girls bathrooms while the boys bathroom is located on the second floor. The first floor bathroom had a mysterious puddle that would occasionally appear, which caused a bit of confusion and chaos at times. It would even migrate across the floor... Many of the “thirdfloorians” were elusive, only being spotted in the first floor lounge a few times. This lead to the rumor that the third floor was a “scary version of Narnia.” It was later discovered that the third floor did not house scary people, rather the first and second floors were at fault because no one ventured to the third floor as they were too lazy.
Lounge activities:
	The lounge, located on the first floor, was the hub of all activity in the dorm. Several students entertained themselves with marathon games of Settlers of Catan, Egyptian war,  Risk, Arkham Horror and Illuminati. Contrary to popular belief, these games were not their only source of entertainment—Doctor Who was their other source. There were massive Doctor Who viewings in the Talara lounge (briefly referred to as the “TALARIS” by those versed in Doctor Who slang), which could attract up to twenty freshmen in one evening. Between lateSeptember and midFebruary, these students watched 6 seasons of Doctor Who. Many Talarians caught the Doctor Who epidemic however, there were several who resisted for the entire year. Game of Thrones became another popular show in Talara, however it was not known to attract the same sized crowds as Doctor Who. Not only was the lounge a spot for games, TV, wiki races and studying, it was also the place where several birthday parties were held. A birthday party usually consisted of cake and other inexpensive foods that starving college kids will eat (which is practically anything, except the failed coconut cake which looked like apple sauce and was absolutely disgusting). On the evening of April 13, 2012, the lounge also housed a gigantic blanket fort for a few hours which nearly filled the entire room. It was dismantled before the RAs on call made their rounds.
Art:
	  Throughout the course of the year, many elegant drawings appeared on whiteboards, and the hall poster was a masterpiece of a weeping angel (though many did not see it). Another time, chalk drawings sprung up on the walkways outside of Talara. Eventually this turned into a dorm bonding chalk drawing day. The RAs even had a painting event and then turned the lounge into a gallery of fine art painted in under an hour.
Odd Sightings:
	Many quirky things could be spotted in Talara. A pair of glasses had a permanent home in the lounge for the entire year. No one knew who they belonged to. Some of the walls sported murals of subjects such as flowers, Calvin and Hobbes, a whale, strange fruit creatures and two pandas (referred to by some as Bamboo and Clyde). During Thanksgiving break, many paper signs appeared around the entire dorm (intended to be a joke on the one resident who was staying in the halls during break). There was even a giant squid to keep her company named La Fleur. Spring quarter not only brought sunshine and outside study time to Talarians, it also sprouted a mysterious handicapped sign in front of the bike parking area. As suddenly as it arrived, the little stickfigure in a wheelchair sign soon disappeared. Finally, it is said that there are several copies of the same letter hidden around Talara from one of the residents from 20112012 to the Talara residents of 20122013. However, cleaning staff may have found them and disposed of them.
Rivals:
	Indio was Talaras main rival. There were several ultimate frisbee matches to determine which dorm was dominant. Even eating at the dining commons became a competition. Whichever dorm had more people eating together for dinner won. Some Talarians brainstormed pranks to pull on Indio. However, between the time of the creation of the plans and the date on which they were to be perpetrated, Talara and Indio lessened their rivalry and became friends. Moral of the story: Dont make friends.
Honorary Talarians:
	The title of “Honorary Talarian” is a term that is not applied lightly to every visitor who steps into the magnificent dorm. There is no exact formula for determining an Honorary Talarian, but it has been noted that if a student spends more time in Talara than in their own dorm, they are an Honorary Talarian. This title was officially bestowed when an RA would add the Honorary Talarian to the Talara 20112012 facebook page.


!
!     -------------------------------------------------------------
!      I X J T I K
!     -------------------------------------------------------------
!
!                                                                  *
!     CHESKED TRIANGULAR CONDITIONS FOR 6j COEFFICIENT             *
!                                                                  *
!     | I/2  J/2  K/2 |            IXJTIK=1 - IF NOT SATISFY       *
!     | L/2  M/2  N/2 |            IXJTIK=0 - IN OVER CASES        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                          December 1993   *
!
      INTEGER FUNCTION IXJTIK (I, J, K, L, M, N)
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:51:45  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: K
      INTEGER  :: L
      INTEGER  :: M
      INTEGER  :: N
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      IXJTIK = 0
      IF (ITTK(I,J,K) == 0) RETURN
      IF (ITTK(I,M,N) == 0) RETURN
      IF (ITTK(L,J,N) == 0) RETURN
      IF (ITTK(L,M,K) == 0) RETURN
      IXJTIK = 1
      RETURN
      END FUNCTION IXJTIK


text:
      subroutine fcombined(sy,dsy,sb,dsb,deqpl,dtime,temp,
     & statev,tempstatev,nstatv,props,nprops)
c
      implicit real*8(a-h,o-z)
      dimension statev(nstatv),tempstatev(nstatv),props(nprops)
c
      parameter(zero=0.d0,half=0.5d0,one=1.d0,two=2.d0,newtonmax=10,
     & toler=1.0d-8,ratemin=1.d-10)
c
c     material properties
      emu0=props(1)
      ed0=props(2)
      et0=props(3)
c     props(4) is used for poisson's ratio
c     stress values
      sa=props(5)
      s0=props(6)
c     scaling function
      a0e=props(7)
      pe=props(8)
      qe=props(9)
      rate0=props(10)
c     evolve misorient
      cld=props(11)
c     geometric disl
      cg=props(12)
      rg=props(13)
c     accumulation
      c1=props(14)
c     dynamic recovery
      c20=props(15)
      a02=props(16)
      rate02=props(17)
c     thermal recovery
      c30=props(18)
      a03=props(19)
      r3=props(20)
c     recoverable
      c4=props(21)
      c50=props(22)
      a05=props(23)
c     back stress
      c6=props(24)
      c7=props(25)
c
c     check
      rate = deqpl/dtime
      if(rate.lt.ratemin)then
        rate = ratemin
      endif
c
c     statevariables
      x1p=statev(1) !misorientation
      x2p=statev(2) !dislocation ratio
      x3p=statev(3) !recoverable disl.
c     previous back stress:
      sbp=statev(4)
c
      emu=emu0-ed0/(dexp(et0/temp)-one)
      emusf=emu/emu0
c
c     scaling function
      sfe0=temp/(a0e*emu)
      sfle=dlog(rate0/rate)*sfe0
      sfe=(one-sfle**(one/qe))**(one/pe)
c
c     dynamic recovery
      c2t=-temp/(emu*a02)
      c2=c20*dexp(c2t*dlog(rate/rate0))
      dc2drt=c2*c2t
c
c     thermal recovery
      c3=c30*dexp(-a03/temp)*dtime
      c5=c50*dexp(-a05/temp)*dtime
c
c     update lattice incompatibility
      x1=x1p+cld*deqpl
c     initial guess for dislocation dens.
      x2=x2p
      sqx2=dsqrt(x2)
c
      f=-deqpl*(cg*x1**rg+c1*sqx2-c2*x2)+c3*x2**r3
      ddf=one-deqpl*(half*c1/sqx2-c2)
      if(dabs(f).gt.toler)then
      kount=0
      do while((dabs(f).gt.toler).and.(kount.lt.newtonmax))
      kount=kount+1
      x2=dabs(x2-f/ddf)
      sqx2=dsqrt(x2)
      f=x2-x2p-deqpl*(cg*x1**rg+c1*sqx2-c2*x2)+c3*x2**r3
      ddf=one-deqpl*(half*c1/sqx2-c2)
      enddo
      endif
      x3=(x3p+deqpl*c4*sqx2)/(one+deqpl*c2+c5)
c
c     equivalent threshold and yield stress
      sec=s0*sqx2
      sy=sa+emusf*sfe*sec
c     back stress
      sbnum=sbp+deqpl*c6*sqx2
      sbden=one+deqpl*c7
      sb=sbnum/sbden
c
c     dislocation sensitivity (EQ. 5.44)
      dx2de=(cg*x1**rg+c1*sqx2-c2*x2-dc2drt*x2+
     & deqpl*rg*cg*cld*(x1**(rg-one)))/ddf
c     isotropic senistivity
      dsec=half*s0*dx2de/sqx2
      dsfe=sfe0*(one-sfle**(one/qe))**(one/pe-one)*
     & sfle**(one/qe-one)/(pe*qe*rate*dtime)
      dsy=emusf*(sfe*dsec+dsfe*sec)
c     back stress sensitivity
      dsb=(c6*sqx2 + half*deqpl*c6*dx2de/sqx2)/sbden-
     & c7*sbnum/(sbden**two)
c
c     update temporary state variable array
      tempstatev(1)=x1
      tempstatev(2)=x2
      tempstatev(3)=x3
      tempstatev(4)=sb
c
      return
      end

max_stars_repo_name: jacojvr/UMATs

max_issues_repo_name: jacojvr/UMATs

max_forks_repo_name: jacojvr/UMATs


text: At the Davis Cemetery there are two Labyrinths. One is cut into the grass near the flagpole, and the other is on the south side around a tree. The second labyrinth was planned and built under the direction of Adam Borchard of Boy Scouts Troop 111 for his Eagle Scout project.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


program win32
use M_escape, only: fg_red, bg_default, bold, reset, M_escape_initialize
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(kind=c_int) :: i

i = M_escape_initialize()
print *, fg_red, bg_default, bold, 'Hello!', reset

end program


text: #redirect California National Primate Research Center


text:
/*

DefineUnit(ensureInternal('|commsUnit:NSB|), {
	commsUnit:	getlayout("commsUnit"),
	BITUnit:	  getlayout("BITUnit")
});

InstallScript := func(partFrame, removeFrame)
	begin
		// need this (for now) or we throw
	end;

RemoveScript := func(removeFrame)
	begin
		// need this (for now) or we throw
	end;
*/

definition := EnsureInternal(Clone(kCommsUnitFrame));
definition.commsUnit := getlayout("commsUnit");
definition.BITUnit := getlayout("BITUnit");

DefineUnit(EnsureInternal('|commsUnit:NSB|), definition);

InstallScript := func(partFrame, removeFrame) nil;
RemoveScript := func(removeFrame) nil;

max_stars_repo_path: src/4.00 - never released/Unit- Communications/commsUnit.f

max_stars_repo_name: aladds/NS-Basic-for-Newton-OS

max_issues_repo_name: aladds/NS-Basic-for-Newton-OS

max_forks_repo_name: aladds/NS-Basic-for-Newton-OS


text:
! =============================================================================
! This module stores the parcel data and provides subroutines to write, modify
! allocate and deallocate it.
! =============================================================================
module parcel_container
    use options, only : verbose
    use parameters, only : extent, hli, center, lower, upper
    use parcel_ellipsoid, only : parcel_ellipsoid_allocate, parcel_ellipsoid_deallocate
    implicit none

    integer :: n_parcels

    type parcel_container_type
        double precision, allocatable, dimension(:, :) :: &
            position,   &
            vorticity,  &
            B               ! B matrix entries; ordering:
                            ! B(:, 1) = B11, B(:, 2) = B12, B(:, 3) = B13
                            ! B(:, 4) = B22, B(:, 5) = B23

        double precision, allocatable, dimension(:) :: &
            volume,     &
#ifndef ENABLE_DRY_MODE
            humidity,   &
#endif
            buoyancy
    end type parcel_container_type

    type(parcel_container_type) parcels

    contains

        ! Obtain the difference between two zonal coordinates
        ! across periodic edges
        ! @param[in] x1 first zonal position
        ! @param[in] x2 second zonal position
        ! @returns delx = x1 - x2
        ! WARNING input needs to be between lower and upper (see debug statement)
#ifndef NDEBUG
        function get_delx(x1, x2) result (delx)
#else
        elemental function get_delx(x1, x2) result (delx)
#endif
            double precision, intent(in) :: x1, x2
            double precision             :: delx

            delx = x1 - x2
#ifndef NDEBUG
            if ((x1 < lower(1)) .or. (x2 < lower(1)) .or. (x1 > upper(1)) .or. (x2 > upper(1))) then
                write(*,*) 'point outside domain was fed into get_delx'
                write(*,*) 'x1, x2, lower(1), upper(1)'
                write(*,*) x1, x2, lower(1), upper(1)
            endif
#endif
            ! works across periodic edge
            delx = delx - extent(1) * dble(int(delx * hli(1)))
        end function get_delx

        ! Obtain the difference between two meridional coordinates
        ! across periodic edges
        ! @param[in] y1 first meridional position
        ! @param[in] y2 second meridional position
        ! @returns dely = y1 - y2
        ! WARNING input needs to be between lower and upper (see debug statement)
#ifndef NDEBUG
        function get_dely(y1, y2) result (dely)
#else
        elemental function get_dely(y1, y2) result (dely)
#endif
            double precision, intent(in) :: y1, y2
            double precision             :: dely

            dely = y1 - y2
#ifndef NDEBUG
            if ((y1 < lower(2)) .or. (y2 < lower(2)) .or. (y1 > upper(2)) .or. (y2 > upper(2))) then
                write(*,*) 'point outside domain was fed into get_dely'
                write(*,*) 'y1, y2, lower(2), upper(2)'
                write(*,*) y1, y2, lower(2), upper(2)
            endif
#endif
            ! works across periodic edge
            dely = dely - extent(2) * dble(int(dely * hli(2)))
        end function get_dely

        ! Overwrite parcel n with parcel m
        ! @param[in] n index of parcel to be replaced
        ! @param[in] m index of parcel used to replace parcel at index n
        ! @pre n and m must be valid parcel indices
        subroutine parcel_replace(n, m)
            integer, intent(in) :: n, m

#ifdef ENABLE_VERBOSE
            if (verbose) then
                print '(a19, i0, a6, i0)', '    replace parcel ', n, ' with ', m
            endif
#endif

            parcels%position(:, n) = parcels%position(:, m)

            parcels%vorticity(:, n) = parcels%vorticity(:, m)

            parcels%volume(n)  = parcels%volume(m)
            parcels%buoyancy(n) = parcels%buoyancy(m)
#ifndef ENABLE_DRY_MODE
            parcels%humidity(n) = parcels%humidity(m)
#endif
            parcels%B(:, n) = parcels%B(:, m)

        end subroutine parcel_replace

        ! Allocate parcel memory
        ! @param[in] num number of parcels
        subroutine parcel_alloc(num)
            integer, intent(in) :: num

            allocate(parcels%position(3, num))
            allocate(parcels%vorticity(3, num))
            allocate(parcels%B(5, num))
            allocate(parcels%volume(num))
            allocate(parcels%buoyancy(num))
#ifndef ENABLE_DRY_MODE
            allocate(parcels%humidity(num))
#endif
            call parcel_ellipsoid_allocate
        end subroutine parcel_alloc

        ! Deallocate parcel memory
        subroutine parcel_dealloc
            deallocate(parcels%position)
            deallocate(parcels%vorticity)
            deallocate(parcels%B)
            deallocate(parcels%volume)
            deallocate(parcels%buoyancy)
#ifndef ENABLE_DRY_MODE
            deallocate(parcels%humidity)
#endif
            call parcel_ellipsoid_deallocate
        end subroutine parcel_dealloc

end module parcel_container

max_stars_repo_name: matt-frey/epic

max_issues_repo_name: matt-frey/epic

max_forks_repo_name: matt-frey/epic