! { dg-do run }
! Test the fix for PR47523 in which concatenations did not work
! correctly with assignments to deferred character length scalars.
!
! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
!
program main
  implicit none
  character(:), allocatable :: a, b
  a = 'a'
  if (a .ne. 'a') STOP 1
  a = a // 'x'
  if (a .ne. 'ax') STOP 2
  if (len (a) .ne. 2) STOP 3
  a = (a(2:2))
  if (a .ne. 'x') STOP 4
  if (len (a) .ne. 1) STOP 5
end program main


text:
	SUBROUTINE DSFILL  ( szfil, iftyp, size, jtype, iret )
C************************************************************************
C* DSFILL								*
C* 									*
C* This subroutine sets the polygon fill attributes.  If these 		*
C* attributes are not positive, no changes are made.   			*
C* 									*
C* DSFILL  ( SZFIL, IFTYP, SIZE, JTYPE, IRET )				*
C*                                                                    	*
C* Input parameters:							*
C* 	SZFIL		REAL		Fill pattern size             	*
C* 					  <=0 = no change		*
C*      IFTYP		INTEGER		Fill pattern type             	*
C*                                        <=0 = no change		*
C* Output parameters:							*
C*	SIZE		REAL		Fill pattern size		*
C*	JTYPE		INTEGER		Fill pattern type		*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* S. Maxwell/GSC	 6/97						*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'DEVACT.CMN'
	INCLUDE		'DEVCHR.CMN'
C-----------------------------------------------------------------------
	iret = NORMAL
C*
	IF  ( szfil .gt. 0. )   tfilsz = szfil
	IF  ( iftyp .gt. 0  )   mfltyp = iftyp
	size  = tfilsz
        jtype = mfltyp
C
C*	Send the information to the driver.
C
	CALL HSFILL ( size, jtype, ier )
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


! Copyright (c) 2019, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

! Check that implicitly typed entities get a type in the module file.

module m
  public :: a
  private :: b
  protected :: i
  allocatable :: j
end

!Expect: m.mod
!module m
! real(4)::a
! real(4),private::b
! integer(4),protected::i
! integer(4),allocatable::j
!end


text:
C     SOLVE QUADRATIC EQUATION IN FORTRAN I
      READ 100,A,B,C
100   FORMAT(3F12.4)
      DISCR = B**2-4*A*C
      IF (DISCR) 10,20,30
10    X1=(-B)/(2.*A)
      X2=SQRTF(ABSF(DISCR))/(2.*A)
      PRINT 110,X1,X2
110   FORMAT(5H X = ,F12.3,4H +i ,F12.3)
      PRINT 120,X1,X2
120   FORMAT(5H X = ,F12.3,4H -i ,F12.3)
      GOTO 40
20    X1=(-B)/(2.*A)
      PRINT 130,X1
130   FORMAT(11H X1 = X2 = ,F12.3)
      GOTO 40
30    X1=((-B)+SQRTF(ABSF(DISCR)))/(2.*A)
      X2=((-B)-SQRTF(ABSF(DISCR)))/(2.*A)
      PRINT 140,X1
140   FORMAT(6H X1 = ,F12.3)
      PRINT 150,X2
150   FORMAT(6H X2 = ,F12.3)
40    CONTINUE
      STOP 25252

ext: for


! { dg-do run }
! PR fortran/83864
!
! Derived from PR by Contributed by Gerhard Steinmetz <gscfq@t-online.de>
!
program p
  implicit none
  type t
     character :: c(3) = transfer('abc','z',3)
  end type t
  type(t) :: x
  if (any (x%c /= ["a", "b", "c"])) call abort ()
end


text:
## This page gets included into the larger Dancing page

These are Dancing Dance Classes in Davis. Some are held at Dance Studios and others at a variety of other locations.

  Dance troupe Kanz alSahara is teaching belly dance classes at the Davis Arts Center Summer 2014 on Wednesdays 6:308:00pm https://kanzalsahara.squarespace.com/events/ Link for more info

  Aalim Middle Eastern Dance is a new Middle Eastern dance academy that is originally from London, then St. Louis and now right here in Davis. It teaches the various cabaret styles of Raks Sharki/ Oriental dance (bellydance) as well as folkloric styles from many different countries. Classes are taught by Lili who has 10 years of performing experience in St. Louis, MO as well as San Juan, PR as well as 4 years of teaching experience with Aalim Dance Co. Classes are for all ages, shapes and sizes and are meant for both total beginners and those that have already had some experience with bellydance. Classes are held independently at Barbaras Dancing Tonight Studio on Sundays from 8:309:30pm. Classes cost 6 for $50 ($8.33/ class) or a dropin rate of $10/ class. Private lessons also available. You can contact LILI at lilibellydance@yahoo.com. THIS EMAIL DOESNT WORK, PLEASE POST A WORKING ADDRESS, I TRIED TO CONTACT YOU :)
  Argentine Tango with Miguel TaillantMiguel Taillant, a native of Argentina, has been teaching tango for over 35 years.  Classes Spring 2013 quarter are at South Silo on Sundays from 3 to 5 pm.  Contact tangobravo2k@yahoo.com if you have any questions.
  Barbaras Dancing Tonight teaches a variety of dance styles from hip hop to swing and ballroom. Barbara usually offers a few of her more popular introductory courses at a very low rate through http://www.city.davis.ca.us/pcs Davis Parks & Community Services. This is a good way to find out if you like her style as well as a particular dance style; Barbara also employs other instructors who specialize in different dance styles. If you choose to sign up for classes through the dance studio, you can purchase these on a dropin basis for greater flexibility.

  Davis STAGES offers jazz, tap, and ballet for children and adults  All Levels Welcomed! http://www.davisstages.com/ Stages Dance Studio

  The Davis International Folk Dancers is an underground remnant of the 1950s and 60s folk dance movement where dances from Bulgaria, Israel, Greece, Armenia, and other countries with strange and wonderful dance traditions are given new life.  The leaders of the group teach a class most Sunday evenings at the Davis Art Center, 7pm to 10pm, with all requests during the last hour.  The dances range from simple to complex, from exotic to more popular.  The members also make appearances at other locations and times for specific types of dance, such as Davis Israeli Dancing and Balkan folk dancing.
 Davis Israeli Dancing is for dancers of all ages and all levels of experience.  Open to the public, Davis Israeli Dancing is held on the first and third Thursday of the month from 7 to 9 pm at Congregation Bet Haverim social hall.
  Davis Swing Dancers
  The International House Davis offers Salsa classes every Monday evening from 7:30 pm to 8:30 pm, taught by Carlos Whyles, as well as Tango classes every Tuesday evening from 6 pm to 7:30 pm, taught by Damien Kima.  Classes are free for IHouse members or $10 per class to drop in.  IHouse also hosts occasional one evening dance workshops, see their http://www.internationalhousedavis.org/newsevents/calendar2/ calendar for upcoming events.
  The International Social Dance Club is a new student organization that will be starting up in Fall 2008.  Like the Davis International Folk Dancers they will do a wide variety of dances from around the world, but with a greater emphasis on western European partner dances (waltz, polka etc.) and more regular teaching.  The club meets Wednesday nights from 810 in the ARC Pavilion. When you enter the Pavilion from the ARC side, follow the signs to the club.
  Spotlight Dance & Fitness  A ballroom, latin, and swing dance studio in West Sacramento.  About a 10 minute drive from Davis, with a very friendly and supportive group of students and staff.  The instructors here are all professional dancers and instructors, so whether you are a complete beginner, or a seasoned veteran, you are sure to get a quality dance education at Spotlight.  Many Davisites and UCD students take classes here.
  Parks & Community Services Department Davis Parks & Community Services offers dance courses through their http://www.city.davis.ca.us/pcs/download/ Recreation Program. These classes are very reasonably priced, and instruction is typically by professional dance instructors.
  Popping Club @ UC Davis teaches popping, a funk style, at the ARC Pavilion or ARC Dance Studio four days a week (Monday  Thursday) and is open to all skill levels. Check the official website calendar for more information regarding lessons and open sessions.
  The Sacramento Country Dancing Society puts on a Contra Dance every 3rd Friday at the Davis High School Dance Room from 811pm with a beginners workshop at 7:30pm. The cost is $5 for students and $10 for adults, with a maximum of $25 per family.
 Experimental College regularly offers a variety of dance styles at reasonable prices, including salsa, capoeira, and sometimes samba. Be sure to check the EC Guide at the start of each quarter to find out when classes will be held.  In Spring 2010 Davis Ecstatic Dance is offered.
  The Graduate and many other dance clubs often offer a free 30 minute or hour long lesson with your cover charge before they begin spinning beats. This is particularly true of certain styles such as country line, swing, and salsa... youre not likely to get an intro to hip hop at any club!
  http://www.dynamicdancing.com Dynamic Dancing with Yvette  Yvette teaches a variety of dance styles including: Jazz, Ballet, Tap, Musical Theatre, Hip Hop and Bellydance. Classes are taught at three Davis locations and in Woodland.
  Irish Dancing is taught at the Davis Art Center for kids, teens, and adults of various skill and energy levels.
  Pamela Trokanski Dance Workshop and Performing Arts Center offers a variety of classes, including  Modern/Contemporary, Ballet, Pointe, Jazz, Hip Hop, Dance Team, Belly Dance (both Traditional Cabaret Style and American Fusion Style,) Fire Dance, Cheer Dance, Zumba, Dance Improvisation and Body Conditioning Classes for Dancers. The Dance Workshop also runs FREE Dance for Parkinsons classes, which are classes specifically geared for people with Parkinsons Disease. During the summer, the Dance Workshop also offers a wide range of week long dance camps and intensives ranging from dance camps that offer younger dancers an experience with multiple dance forms to intensives that focus on technique, repertory, and performance, both live and for DVD audition choreography. It is the school for the Pamela Trokanski Dance Theatre. The experienced, thirteen member, faculty brings both breadth and depth to a dancers training. Visit our web site at http://www.trokanski.com.
  The ARC is now offering all sorts of dance classes, from Ballroom and Salsa to Bellydancing and Ballet.  They are offered each quarter and are taught by a very knowledgeable group of instructors.  Check the quarterly Recreation Guide (or the ARC website) for more information.
  Hanneke Lohse teaches allages ballet at the Davis Art Center six days a week, and her dance group performs at the Veterans Memorial Theatre twice a year.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!****************************************************************************************************
!
!   Sample program for the iRIC version4.0
!
!****************************************************************************************************
    program samaple
    use iric

    implicit none
    integer, parameter :: strmax = 1024

    integer :: imin, imax, iout, i
    character(len=strmax) :: filename
    integer :: fid, mode, ier
!======================================================================
    write(*,'(a)') "---------- START Sample Solver ---------"
    !write(*,*) NARGS()
    if(NARGS() == 2) then
        call GETARG(1, filename)
        !write(*,*) trim(filename)
    else
        write(*,"(a)") "Error: no argument."
        write(*,"(a)") "usage: "
        write(*,"(a)") "***.exe Case1.cgn"
        stop
    end if

    call cg_iric_open(filename, IRIC_MODE_MODIFY, fid, ier)

    imin = 0
    imax = 10000
    iout = 100

    do i = imin, imax

        if(mod(i, iout) == 0) then
            write(*,*) "i = ", i

            ! output

        end if
    end do

    call cg_iric_close(fid, ier)

    write(*,'(a)') "---------- END: Sample Solver ---------"
    end program


text:
      subroutine undflw
c
c     This subroutine disables underflow trapping. This is not
c     necessary on most modern platform/OS/compiler combinations, as
c     they do not engage in underflow trapping by default at the
c     system level. More commonly, underflow trapping is now a compiler
c     option (which should be turned off in the case of EQ3/6).
c
c     On some (mainly older) systems, underflow trapping is built into
c     the system in a way that can only be overridden for a given
c     program by putting a platform-dependent system subroutine call
c     in that program. If such a call is necessary, it should be made
c     in the present subroutine. If it appears that such a call is
c     necessary, consult your local system documentation, compiler
c     documentation, compiler vendor, or local computer support person
c     to find out what this call should be. Do not call LLNL to find
c     out.
c
c     This subroutine is called by:
c
c       EQPT/eqpt.f
c       EQ3NR/eq3nr.f
c       EQ6/eq6.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       None
c
c     Output:
c
c       None
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
com   BEGIN_MACHINE_DEPENDENT_CODE
com
com     If a system subroutine call is necessary to disable underflow
com     trapping, add it here.
com
com
com   END_MACHINE_DEPENDENT_CODE
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      end


text:
subroutine bar_f (i, j, x, f) bind(C, name = "bar")
  use iso_c_binding
  real (c_float) :: i
  integer (c_int) :: j
  integer (C_LONG) :: x
  character :: f
end subroutine

max_stars_repo_name: ouankou/rose

max_issues_repo_name: WildeGeist/rose

max_forks_repo_name: WildeGeist/rose


text: Hi! Im a UCD alumna that studied Managerial Economics. You can now find me back in the bay area.


text:
C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE REMAP
      IMPLICIT NONE
C
C Purpose: Remap an image according to a given set of remapping points
C          either/or in X & Y directions.
C
      INCLUDE 'COMMON.FOR'
C
C Calls  10: IMDISP , WFRAME , RFRAME , IMSIZE , OUTFIL
C            GETVAL , GETHDR , OPNFIL , OPNNEW , FILL
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      REAL    VALUE(10),XINC,XTOT,GRAD
      INTEGER IRC,IFRAME,IHFMAX,IFRMAX,NPIX,NRAST,NFRAME,IMEM,NCH
      INTEGER KPIC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,NVAL,I,J,K,II
      INTEGER L,M,NCHANX,NCHANY,NPNTX,NPNTY,IFIRST,ILAST,N,NN,NNN,INDEX
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NPIX   : Nos. of pixels in image
C NRAST  : Nos. of rasters in image
C NFRAME : Nos. of frames in dataset
C KPIC   : Current image nos.
C NVAL   : Nos. of values entered at terminal
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
10    KPIC=0
      NPNTX=0
      NPNTY=0
      WRITE (IPRINT,1000)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 999
      IF (IRC.EQ.2) GOTO 10
      IF (NVAL.GE.1) NPNTX=INT(VALUE(1))
      IF (NVAL.GE.2) NPNTY=INT(VALUE(2))
C
C========GET PIXEL REMAPPING DATA
C
      IF (NPNTX.GT.0) THEN
         WRITE (IPRINT,*) 'Pixel remapping file'
         CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,
     &                IFFR,ILFR,IFINC,IHFMAX,IFRMAX,NCHANX,NRAST,IRC)
         IF (IRC.NE.0) GOTO 999
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHANX,NRAST,
     &                NFRAME,IRC)
         IF (IRC.NE.0) GOTO 140
         CALL RFRAME (JUNIT,IFFR,NCHANX,NRAST,SP1,IRC)
         IF (IRC.NE.0) GOTO 140
         CALL FCLOSE (JUNIT)
      ENDIF
C
C========GET RASTER REMAPPING DATA
C
      IF (NPNTY.GT.0) THEN
         WRITE (IPRINT,*) 'Raster remapping file'
         CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,
     &                IFFR,ILFR,IFINC,IHFMAX,IFRMAX,NCHANY,NRAST,IRC)
         IF (IRC.NE.0) GOTO 999
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHANY,NRAST,
     &                NFRAME,IRC)
         IF (IRC.NE.0) GOTO 140
         CALL RFRAME (JUNIT,IFFR,NCHANY,NRAST,SP4,IRC)
         IF (IRC.NE.0) GOTO 140
         CALL FCLOSE (JUNIT)
      ENDIF
C
C========GET HEADER & BINARY FILE ATTRIBUTES
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     &             ILFR,IFINC,IHFMAX,IFRMAX,NPIX,NRAST,IRC)
      IF (IRC.NE.0) GOTO 999
      IFRAME=IHFMAX+IFRMAX-1
C
      DO 130 I=1,IHFMAX
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NPIX,NRAST,
     &                NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 120 J=1,IFRMAX
               CALL RFRAME (JUNIT,IFFR,NPIX,NRAST,SP2,IRC)
               IF (IRC.NE.0) GOTO 140
               IFFR=IFFR+IFINC
               KPIC=KPIC+1
C
C========REMAP PIXELS
C
               CALL FILL (SP3,NPIX*NRAST,0.0)
               IF (NPNTX.NE.0) THEN
                  DO 50 K=1,NRAST
                     II=1
                     N=(K-1)*NPIX
                     DO 40 M=1,NCHANX+1
                        IF (M.EQ.1) THEN
                           IFIRST=1
                           ILAST=SP1(M)-1
                        ELSEIF (M.EQ.NCHANX+1) THEN
                           IFIRST=SP1(M-1)
                           ILAST=NPIX
                        ELSE
                           IFIRST=SP1(M-1)
                           ILAST=SP1(M)-1
                        ENDIF
                        IF (M.EQ.1.OR.M.EQ.NCHANX+1) THEN
                           DO 20 L=IFIRST,ILAST
                              SP3(N+II)=SP2(N+L)
                              II=II+1
20                         CONTINUE
                        ELSE
                           NCH=ILAST-IFIRST+1
                           XINC=REAL(NCH-1)/REAL(NPNTX-1)
                           SP3(N+II)=SP2(N+IFIRST)
                           SP3(N+II+NPNTX-1)=SP2(N+ILAST)
                           XTOT=REAL(IFIRST)
                           DO 30 L=2,NPNTX-1
                              XTOT=XTOT+XINC
                              INDEX=IFIX(XTOT)
                              GRAD=SP2(N+INDEX+1)-SP2(N+INDEX)
                              SP3(N+II+L-1)=GRAD*(XTOT-REAL(INDEX))+
     &                                     SP2(N+INDEX)
30                         CONTINUE
                           II=II+NPNTX
                        ENDIF
40                   CONTINUE
50                CONTINUE
                  IF (NPNTY.NE.0) THEN
                     DO 60 K=1,NPIX*NRAST
                        SP2(K)=SP3(K)
 60                  CONTINUE
                     CALL FILL (SP3,NPIX*NRAST,0.0)
                  ENDIF
               ENDIF
C
C========REMAP RASTERS
C
               IF (NPNTY.NE.0) THEN
                  II=1
                  DO 110 M=1,NCHANY+1
                     IF (M.EQ.1) THEN
                        IFIRST=1
                        ILAST=SP4(M)-1
                     ELSEIF (M.EQ.NCHANY+1) THEN
                        IFIRST=SP4(M-1)
                        ILAST=NRAST
                     ELSE
                        IFIRST=SP4(M-1)
                        ILAST=SP4(M)-1
                     ENDIF
C
C========DON'T REMAP FIRST OR LAST PORTION
C
                     IF (M.EQ.1.OR.M.EQ.NCHANY+1) THEN
                        DO 80 K=IFIRST,ILAST
                           DO 70 L=1,NPIX
                              N=(K-1)*NPIX+L
                              NN=(II-1)*NPIX+L
                              SP3(NN)=SP2(N)
70                         CONTINUE
                           II=II+1
80                      CONTINUE
C
                     ELSE
                        NCH=ILAST-IFIRST+1
                        XINC=REAL(NCH-1)/REAL(NPNTY-1)
                        DO 100 L=1,NPIX
                           N=(IFIRST-1)*NPIX+L
                           NN=(II-1)*NPIX+L
                           SP3(NN)=SP2(N)
                           N=(ILAST-1)*NPIX+L
                           NN=(II+NPNTY-2)*NPIX+L
                           SP3(NN)=SP2(N)
                           XTOT=REAL(IFIRST)
                           DO 90 K=2,NPNTY-1
                              XTOT=XTOT+XINC
                              INDEX=IFIX(XTOT)
                              N=(INDEX-1)*NPIX+L
                              NN=(INDEX)*NPIX+L
                              NNN=(II+K-2)*NPIX+L
                              GRAD=SP2(NN)-SP2(N)
                              SP3(NNN)=GRAD*(XTOT-REAL(INDEX))+
     &                                     SP2(N)
90                         CONTINUE
100                     CONTINUE
                        II=II+NPNTY
                     ENDIF
110               CONTINUE
               ENDIF
C
               IF (IFRAME.EQ.1) CALL IMDISP(ITERM,IPRINT,SP3,NPIX,NRAST)
               IF (KPIC.EQ.1) THEN
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 140
                  CALL OPNNEW (KUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,
     &                         HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 140
               ENDIF
               CALL WFRAME (KUNIT,KPIC,NPIX,NRAST,SP3,IRC)
               IF (IRC.NE.0) GOTO 140
120         CONTINUE
            CALL FCLOSE (JUNIT)
         ENDIF
130   CONTINUE
140   CALL FCLOSE (KUNIT)
      CALL FCLOSE (JUNIT)
      GOTO 10
999   RETURN
1000  FORMAT (' How many remapped points in X & Y [0,0]: ',$)
      END


text:
program test

    use stdlib_io_disp
    use stdlib_string_type
    call disp(string_type("x"))
    call disp([1, 2], "dada")
    block
        real(8) :: r(2, 6), r_2d(50, 20)
        complex :: c(2, 3), c_3d(2, 100, 20)
        integer :: i(2, 3)
        logical :: l(10, 10)
        r = 1.; c = 1.; c_3d = 2.; i = 1; l = .true.
        r(1, 1) = -1.e-11
        r(1, 2) = -1.e10
        c(2, 2) = (-1.e10, -1.e10)
        c_3d(1, 3, 1) = (1000, 0.001)
        c_3d(1, 3, 2) = (1.e4, 100.)
        call random_number(r_2d)
        call disp(string_type('string'), header='disp(string):')
        call disp(string_type('It is a note.'))
        call disp()
        call disp(r, header='disp(r):')
        call disp(r(1, :), header='disp(r(1,:))', brief=.true.)
        call disp(c, header='disp(c):', width=90)
        call disp(i, header='disp(i):')
        call disp(l, header='disp(l):', brief=.true., sep=", ")
        call disp(c_3d(:, 3, :), header='disp(c_3d(:,:,3)):', brief=.true., width=90)
        call disp(100*r_2d, header='disp(r_2d):', brief=.true., width=132, sep=", ")
    end block

    block
        type(string_type) :: s(2)
        s = string_type("abcdefghijk")
        call disp(s, header='disp(s):', width=6)
        call disp(s(1), header='disp(s):', width=6)

        s = string_type(repeat("abcdefghijk", 10))
        call disp(s, header='disp(s):', width=6)
        call disp(s(1), header='disp(s):', width=6)
        s(2) = string_type("abcdefghijk")
        call disp(s, header='disp(s):', width=6)
        call disp("xyz")

    end block

    block

    real    :: r(2, 3)
    complex :: c(2, 3), c_3d(2, 100, 20)
    integer :: i(2, 3)
    logical :: l(10, 10)

    r = 1.; c = 1.; c_3d = 2.; i = 1; l = .true.
    c_3d(1,3,1) = (1000, 0.001)

    call disp('string', header='disp(string):')
    call disp('It is a note.')
    call disp()
    call disp(r, header='disp(r):')
    call disp(r(1,:), header='disp(r(1,:))', format="f6.2")
    call disp(c, header='disp(c):')
    call disp(i, header='disp(i):', sep=",")
    call disp(l, header='disp(l):', brief=.true.)
    call disp(c_3d(:,3,1:10), header='disp(c_3d(:,3,1:10)):', width=100)
    call disp(c_3d(2,:,:), header='disp(c_3d(2,:,:)):', brief=.true.)

    end block

end program test

max_stars_repo_name: zoziha/stdlib-disp-draft

max_issues_repo_name: zoziha/stdlib-disp-draft

max_forks_repo_name: zoziha/stdlib-disp-draft


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_grp_k
  USE m_juDFT

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: grp_k, euler

CONTAINS

  SUBROUTINE grp_k(sym,mrot_k,cell,bk,nclass,nirr,char_table,&
                   grpname,irrname,su,sp_alph,sp_beta)

    !************************************************************
    !
    !   Determines the group of k, returns the number of classes, the name of the
    !   group, the irreducible representations and the character table.
    !   All the groups are not implemented yet, and the identification is not tested for
    !   the groups.
    !
    !  The subroutine works also with double groups, however, no double groups are
    !  tabulated at the moment.
    !
    !
    !   Character tables are taken from
    !   T. Inui, Y Tanabe, and Y. Onodera, "Group theory and its applications in physics",
    !   Springer (1996)
    !
    !   Jussi Enkovaara, Juelich 2004
    !**************************************************************

    !      USE m_mrot2su
    USE m_inv3
    USE m_constants
    USE m_socsym,    ONLY : soc_sym, cross
    USE m_types
    IMPLICIT NONE

    TYPE(t_sym),INTENT(IN)   :: sym
    TYPE(t_cell),INTENT(IN)   :: cell

    REAL,INTENT(IN)      :: bk(3)
    COMPLEX, INTENT(OUT) :: char_table(:,:)
    INTEGER, INTENT(OUT) :: mrot_k(:,:,:),nclass,nirr
    CHARACTER(LEN=7),  INTENT(OUT) :: grpname
    CHARACTER(LEN=5),  INTENT(OUT) :: irrname(:)
    COMPLEX, OPTIONAL, INTENT(OUT) :: su(:,:,:)
    REAL,    OPTIONAL, INTENT(IN)  :: sp_alph,sp_beta ! spin quant. axis

    ! locals
    INTEGER ::  nopk,c
    LOGICAL, ALLOCATABLE :: error(:)
    INTEGER :: mrot2(3,3,48)
    REAL    :: ktest(3),rtmp,rtmp2(4),kt(3)
    INTEGER :: mtest(3,3),mtmp(3,3),mtmpinv(3,3),munit(3,3)
    INTEGER :: n,n2 ,i,itmp
    INTEGER :: elem(48),belongs(48),members(48)
    LOGICAL :: soc,l_sorted
    ! COMPLEX :: sutmp(2,2), sutmpinv(2,2), su2(2,2,48)
    COMPLEX :: sutest(2,2)
    INTEGER :: d,det(48),rot(12),rot_type(48)
    REAL :: alpha,beta,gamma,theta(48),rax(4,48)
    REAL,PARAMETER :: eps=0.000001
    COMPLEX :: omega
    COMPLEX,PARAMETER :: one=CMPLX(1.0,0.0),zero=CMPLX(0.0,0.0)
    COMPLEX,PARAMETER :: imi=CMPLX(0.0,1.0)

    soc=.FALSE.
    IF (PRESENT(su)) soc=.TRUE.
    !sym%nop=SIZE(sym%mrot,3)

    ALLOCATE(error(sym%nop))
    error=.FALSE.
    ! Reduce the symmetry due to spin-orbit
    IF (soc.AND.PRESENT(sp_alph)) THEN
       CALL soc_sym(sym%nop,sym%mrot,sp_beta,sp_alph,cell%amat,error)!keep
    ENDIF

    ! determine the group of k
    nopk=0
    ksymloop: DO n=1,sym%nop
       ktest(1)=bk(1)-sym%mrot(1,1,n)*bk(1)-sym%mrot(2,1,n)*bk(2)-sym%mrot(3,1,n)*bk(3)
       ktest(2)=bk(2)-sym%mrot(1,2,n)*bk(1)-sym%mrot(2,2,n)*bk(2)-sym%mrot(3,2,n)*bk(3)
       ktest(3)=bk(3)-sym%mrot(1,3,n)*bk(1)-sym%mrot(2,3,n)*bk(2)-sym%mrot(3,3,n)*bk(3)
       IF (( ABS( ktest(1) - NINT(ktest(1)) ) < eps ) .AND.&
            &         ( ABS( ktest(2) - NINT(ktest(2)) ) < eps ) .AND.&
            &         ( ABS( ktest(3) - NINT(ktest(3)) ) < eps ) .AND.&
            &         (.NOT.error(n)) ) THEN
          nopk=nopk+1
          mrot_k(:,:,nopk)=sym%mrot(:,:,n)
          CYCLE ksymloop
       ENDIF
    ENDDO ksymloop

    DEALLOCATE(error)

    ! Determine the spin-rotations
    ! Double groups not used at the moment, the groups are classified
    ! without the spin rotations
    !       IF (soc) CALL mrot2su(mrot_k(:,:,1:nopk),amat,su)

    ! identify the group
    ! first determine the classes
    members=1
    nclass=1
    elem(nclass)=1
    belongs(1)=1
    !       IF (soc) THEN
    ! double group
    !         DO n=1,nopk
    !            mrot_k(:,:,n+nopk)=mrot_k(:,:,n)
    !            su(:,:,n+nopk)=-su(:,:,n)
    !         ENDDO
    !         nopk=2*nopk
    !       ENDIF

    cloop: DO n=2,nopk
       DO n2=1,nopk
          mtmp=mrot_k(:,:,n2)
          CALL inv3(mrot_k(:,:,n2),mtmpinv,d)
          mtest=MATMUL(MATMUL(mtmp,mrot_k(:,:,n)),mtmpinv)
          !            IF (soc) THEN
          !               sutmp=su(:,:,n2)
          !               sutmpinv=CONJG(TRANSPOSE(sutmp))
          !               sutest=MATMUL(MATMUL(sutmp,su(:,:,n)),sutmpinv)
          !            ENDIF
          DO c=1,nclass
             !               IF (soc) THEN
             !                  IF (ALL((mtest-mrot_k(:,:,elem(c))).EQ.0).AND.
             !c     &   ALL(ABS(REAL(sutest-su(:,:,elem(c)))).LE.0.0001).AND.
             !     &   ALL(ABS(AIMAG(sutest-su(:,:,elem(c)))).LE.0.0001)) THEN
             !                     belongs(n)=c
             !                     CYCLE classloop
             !                  ENDIF
             !               ELSE
             IF (ALL((mtest-mrot_k(:,:,elem(c))).EQ.0)) THEN
                belongs(n)=c
                members(c)=members(c)+1
                CYCLE cloop
             ENDIF
             !               ENDIF
          ENDDO
       ENDDO
       nclass=nclass+1
       elem(nclass)=n
       belongs(n)=nclass
    ENDDO cloop
    nirr=nclass
    IF (soc) nirr=2*nclass

    ! sort the classes according the rotation type
    mrot2(:,:,1:nopk)=mrot_k(:,:,1:nopk)
    DO c=1,nclass
       mrot_k(:,:,c)=mrot2(:,:,elem(c))
    ENDDO
    !        IF (soc) THEN
    !           su2(:,:,1:nopk)=su(:,:,1:nopk)
    !           DO c=1,nclass
    !              su(:,:,c)=su2(:,:,elem(c))
    !           ENDDO
    !        ENDIF

    ! identify the group
    rot=0
    rot_type=0
    ! rot_type: 2=two fold rot, 3=three fold rot, etc, 7=identity
    !           8=two fold improper rot, ...
    munit=0
    munit(1,1)=1
    munit(2,2)=1
    munit(3,3)=1
    ! determine the number of different rotations
    DO c=1,nclass
       det(c)=&
            &      mrot_k(1,1,c)*mrot_k(2,2,c)*mrot_k(3,3,c)+&
            &      mrot_k(1,2,c)*mrot_k(2,3,c)*mrot_k(3,1,c)+&
            &      mrot_k(2,1,c)*mrot_k(3,2,c)*mrot_k(1,3,c)-&
            &      mrot_k(1,3,c)*mrot_k(2,2,c)*mrot_k(3,1,c)-&
            &      mrot_k(2,3,c)*mrot_k(3,2,c)*mrot_k(1,1,c)-&
            &      mrot_k(2,1,c)*mrot_k(1,2,c)*mrot_k(3,3,c)
       mtest=det(c)*mrot_k(:,:,c)
       rotloop: DO i=1,6
          IF (ALL((mtest-munit).EQ.0)) THEN
             rot(i+(1-det(c))*3)=rot(i+(1-det(c))*3)+1
             IF (i.EQ.1) THEN
                rot_type(c)=7-(1-det(c))*3
             ELSE
                rot_type(c)=i-(1-det(c))*3
             ENDIF
             EXIT rotloop
          ENDIF
          mtest=MATMUL(det(c)*mrot_k(:,:,c),mtest)
       ENDDO rotloop
       IF (ANY((mtest-munit).NE.0)) THEN
          WRITE(oUnit,*) 'grp_k: Cannot find the order of rotation'
       ENDIF
       IF ((rot(5).GT.0).OR.(rot(11).GT.0)) THEN
          WRITE(oUnit,*) 'grp_k: 5 fold rotation found!'
       ENDIF
       CALL euler(c,sym,cell,alpha,beta,gamma)
       CALL rotaxis(alpha,beta,gamma,rax(1:4,c),theta(c))
       IF (soc) THEN
          su(1,1,c)=COS(beta/2.0)*EXP(CMPLX(0.0,-(alpha+gamma)/2.0))
          su(1,2,c)=-SIN(beta/2.0)*EXP(CMPLX(0.0,-(alpha-gamma)/2.0))
          su(2,1,c)=SIN(beta/2.0)*EXP(CMPLX(0.0,(alpha-gamma)/2.0))
          su(2,2,c)=COS(beta/2.0)*EXP(CMPLX(0.0,(alpha+gamma)/2.0))
       ENDIF
    ENDDO

    !<-- Sort the classes
    ! The group elements are sorted in the following way:
    ! First the proper rotations, then improper ones, with increasing rotation angle
    ! Rotations with the same angle are arranged with increasing magnitude of the rotation
    ! axis, e.g. (I, 90 deg around 001, 90 around 110, mirror, ...

    l_sorted=.FALSE.
    DO WHILE (.NOT.l_sorted)
       l_sorted=.TRUE.
       DO c=1,nclass-1
          IF (rot_type(c).LT.rot_type(c+1)) THEN
             mtest=mrot_k(:,:,c)
             mrot_k(:,:,c)=mrot_k(:,:,c+1)
             mrot_k(:,:,c+1)=mtest
             rtmp=theta(c)
             theta(c)=theta(c+1)
             theta(c+1)=rtmp
             rtmp2=rax(:,c)
             rax(:,c)=rax(:,c+1)
             rax(:,c+1)=rtmp2
             itmp=det(c)
             det(c)=det(c+1)
             det(c+1)=itmp
             itmp=rot_type(c)
             rot_type(c)=rot_type(c+1)
             rot_type(c+1)=itmp
             itmp=members(c)
             members(c)=members(c+1)
             members(c+1)=itmp
             IF (soc) THEN
                sutest=su(:,:,c)
                su(:,:,c)=su(:,:,c+1)
                su(:,:,c+1)=sutest
             ENDIF
             l_sorted=.FALSE.
          ENDIF
          IF ((rot_type(c).EQ.rot_type(c+1)).AND.&
               &            (theta(c).GT.theta(c+1))) THEN
             !              IF (theta(c)+(1-det(c))*2.0*pi.GT.
             !     &             theta(c+1)+(1-det(c+1))*2.0*pi) THEN
             mtest=mrot_k(:,:,c)
             mrot_k(:,:,c)=mrot_k(:,:,c+1)
             mrot_k(:,:,c+1)=mtest
             rtmp=theta(c)
             theta(c)=theta(c+1)
             theta(c+1)=rtmp
             rtmp2=rax(:,c)
             rax(:,c)=rax(:,c+1)
             rax(:,c+1)=rtmp2
             itmp=det(c)
             det(c)=det(c+1)
             det(c+1)=itmp
             itmp=members(c)
             members(c)=members(c+1)
             members(c+1)=itmp
             IF (soc) THEN
                sutest=su(:,:,c)
                su(:,:,c)=su(:,:,c+1)
                su(:,:,c+1)=sutest
             ENDIF
             l_sorted=.FALSE.
          ENDIF
          IF ((rot_type(c).EQ.rot_type(c+1)).AND.&
               &            (ABS(theta(c)-theta(c+1)).LT.0.0001).AND.    &
               &            (rax(4,c).GT.rax(4,c+1))) THEN
             !              IF ((ABS(theta(c)+(1-det(c))*2.0*pi-
             !     &           theta(c+1)-(1-det(c+1))*2.0*pi).LT.0.0001).AND.
             !     &           (rax(4,c).GT.rax(4,c+1))) THEN
             mtest=mrot_k(:,:,c)
             mrot_k(:,:,c)=mrot_k(:,:,c+1)
             mrot_k(:,:,c+1)=mtest
             rtmp2=rax(:,c)
             rax(:,c)=rax(:,c+1)
             rax(:,c+1)=rtmp2
             itmp=members(c)
             members(c)=members(c+1)
             members(c+1)=itmp
             IF (soc) THEN
                sutest=su(:,:,c)
                su(:,:,c)=su(:,:,c+1)
                su(:,:,c+1)=sutest
             ENDIF
             l_sorted=.FALSE.
          ENDIF
       ENDDO
    ENDDO
    !>

    WRITE(24,110) bk
    DO c=1,nclass
       IF (det(c).EQ.1) THEN
          WRITE(24,111) NINT(theta(c)*180/pi_const),(rax(1:3,c)),members(c)
       ELSE
          WRITE(24,112) NINT(theta(c)*180/pi_const),(rax(1:3,c)),members(c)
       ENDIF
    ENDDO
110 FORMAT('Symmetry operations of group of k=',3f6.3)
111 FORMAT(i3,1x,'degree proper rotation around ',3f6.2,3x,&
         &      i3,' members in class')
112 FORMAT(i3,1x,'degree improper rotation around ',3f6.2,3x,i3&
         &       ,' members in class')

    !<-- Character tables

    char_table=0.0
    char_table(1,:)=1.0
    grpname='Unknown'
    irrname='Unkno'   ! Only 5 characters wide, cf. ../sympsi.F.
    ! First look the number of classes, within groups with the same number of classes
    ! check the number of different rotations
    SELECT CASE(nclass)
    CASE(1)                           ! only C1
       grpname='C1'
       char_table(1,1)=1.0
       irrname(1)='Gam1'
       IF (soc) THEN
          char_table(2,1)=1.0
          irrname(2)='Gam2'
       ENDIF
    CASE(2)                           ! C-1, C2 and Cs
       IF (rot(2).GT.0) THEN
          grpname='C2'
          char_table(1,1:2)=(/1.0,  1.0/)
          char_table(2,1:2)=(/1.0, -1.0/)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
       ELSE
          grpname='C1h'
          char_table(1,1:2)=(/1.0,  1.0/)
          char_table(2,1:2)=(/1.0, -1.0/)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
          IF (soc) THEN
             char_table(3,1:2)=(/one, -imi/)
             char_table(4,1:2)=(/one,  imi/)
             irrname(3)='Gam3'
             irrname(4)='Gam4'
          ENDIF
       ENDIF
    CASE(3)                           ! C3, D3 and C3v
       IF (ANY(det(1:3).EQ.-1)) THEN
          grpname='C3v'
          char_table(1,1:3)=(/1.0,  1.0,  1.0/)
          char_table(2,1:3)=(/1.0,  1.0, -1.0/)
          char_table(3,1:3)=(/2.0, -1.0,  0.0/)
          irrname(1)='Lam1'
          irrname(2)='Lam2'
          irrname(3)='Lam3'
          IF (soc) THEN
             nirr=6
             char_table(4,1:3)=(/2.0,  1.0,  0.0/)
             char_table(5,1:3)=(/one, -one,  imi/)
             char_table(6,1:3)=(/one, -one, -imi/)
             irrname(4)='Lam6'
             irrname(5)='Lam4'
             irrname(6)='Lam5'
          ENDIF
       ELSE
          grpname='C3'
          omega=EXP(CMPLX(0.0,-2*pi_const/3.0))
          char_table(1,1:3)=(/1.0,  1.0,  1.0/)
          char_table(2,1:3)=(/one, omega, omega**2/)
          char_table(3,1:3)=(/one, omega**2, omega /)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
          irrname(3)='Gam3'
       ENDIF
    CASE(4)                           ! C2h, D2, C2v, C4, S4, and T
       IF((rot(2).EQ.1).AND.(rot(8).EQ.2)) THEN
          grpname='C2v'
          char_table(1,1:4)=(/1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:4)=(/1.0,  1.0, -1.0, -1.0/)
          char_table(3,1:4)=(/1.0, -1.0, -1.0,  1.0/)
          char_table(4,1:4)=(/1.0, -1.0,  1.0, -1.0/)
          irrname(1)='Z1'
          irrname(2)='Z2'
          irrname(3)='Z3'
          irrname(4)='Z4'
       ELSE IF (rot(3).GT.1) THEN
          grpname='T'
          omega=EXP(CMPLX(0.0,-2*pi_const/3.0))
          char_table(1,1:4)=(/1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:4)=(/one,  one, omega, omega**2/)
          char_table(3,1:4)=(/one,  one, omega**2,  omega/)
          char_table(4,1:4)=(/3.0, -1.0,  0.0,  0.0/)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
          irrname(3)='Gam3'
          irrname(4)='Gam4'
       ELSE IF ((rot(4).GT.1).OR.(rot(10).GT.1)) THEN
          IF (rot(4).GT.1) grpname='C4'
          IF (rot(10).GT.1) grpname='S4'
          char_table(1,1:4)=(/1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:4)=(/1.0, -1.0,  1.0, -1.0/)
          char_table(3,1:4)=(/one, -imi, -one,  imi/)
          char_table(4,1:4)=(/one,  imi, -one, -imi/)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
          irrname(3)='Gam3'
          irrname(4)='Gam4'
          IF (soc) THEN
             nirr=8
             omega=EXP(CMPLX(0.0,-pi_const/4.0))
             char_table(5,1:4)=(/one, omega, -imi, &
                  &                   -CONJG(omega)/)
             char_table(6,1:4)=(/one, CONJG(omega), imi, &
                  &                   -omega/)
             char_table(7,1:4)=(/one, -omega, -imi, &
                  &                   CONJG(omega)/)
             char_table(8,1:4)=(/one, -CONJG(omega), imi, &
                  &                   omega/)
             irrname(5)='Gam5'
             irrname(6)='Gam6'
             irrname(7)='Gam7'
             irrname(8)='Gam8'
          ENDIF
       ELSE IF ((rot(2).EQ.1).AND.(rot(8).EQ.1)) THEN
          grpname='ZKUS'
       ENDIF
    CASE(5)                           ! D4, C4v, D2d, O and Td
       IF (rot(3).GT.0) THEN
          grpname='Td'
          char_table(1,1:5)=(/1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:5)=(/1.0, -1.0,  1.0, -1.0,  1.0/)
          char_table(3,1:5)=(/2.0,  0.0,  2.0,  0.0, -1.0/)
          char_table(4,1:5)=(/3.0,  1.0, -1.0, -1.0,  0.0/)
          char_table(5,1:5)=(/3.0, -1.0, -1.0,  1.0,  0.0/)
          irrname(1)='P1'
          irrname(2)='P2'
          irrname(3)='P3'
          irrname(4)='P5'
          irrname(5)='P4'
       ELSE IF (rot(10).GT.0) THEN
          grpname='D2d'
          char_table(1,1:5)=(/1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:5)=(/1.0,  1.0, -1.0,  1.0, -1.0/)
          char_table(3,1:5)=(/1.0,  1.0,  1.0, -1.0, -1.0/)
          char_table(4,1:5)=(/1.0,  1.0, -1.0, -1.0,  1.0/)
          char_table(5,1:5)=(/2.0, -2.0,  0.0,  0.0,  0.0/)
          !               standard order: E, 2, 2_x, -4, m
          irrname(1)='W1'
          irrname(2)='W2'
          irrname(3)='W1`'
          irrname(4)='W2`'
          irrname(5)='W3'
       ELSE
          grpname='C4v'
          char_table(1,1:5)=(/1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:5)=(/1.0,  1.0,  1.0, -1.0, -1.0/)
          char_table(3,1:5)=(/1.0, -1.0,  1.0,  1.0, -1.0/)
          char_table(4,1:5)=(/1.0, -1.0,  1.0, -1.0,  1.0/)
          char_table(5,1:5)=(/2.0,  0.0, -2.0,  0.0,  0.0/)
          irrname(1)='Del1'
          irrname(2)='Del1`'
          irrname(3)='Del2'
          irrname(4)='Del2`'
          irrname(5)='Del5'
       ENDIF
    CASE(6)                           ! C3i, D3d, C6, C3h, D6, C6v and D3h
       IF (rot(2).EQ.0) THEN
          IF (rot(7).EQ.0) THEN
             grpname='C3h'
             char_table(:,:) = 0.0
             WRITE(24,*) 'C3h: Character table missing in grp_k.F'
          ELSE
             grpname='C3i'
             omega=CMPLX(-0.5,SQRT(3./4.))
             char_table(1,1:6)=(/one, one, one, one, one, one/)
             char_table(2,1:6)=(/one, one, one,-one,-one,-one/)
             char_table(3,1:6)=(/one, omega, CONJG(omega),&
                  &                                one, omega, CONJG(omega)/)
             char_table(4,1:6)=(/one, omega, CONJG(omega),&
                  &                               -one,-omega,-CONJG(omega)/)
             char_table(5,1:6)=(/one, CONJG(omega), omega,&
                  &                                one, CONJG(omega), omega/)
             char_table(6,1:6)=(/one, CONJG(omega), omega,&
                  &                               -one,-CONJG(omega),-omega/)
             irrname(1)='Ag  '
             irrname(2)='Au  '
             irrname(3)='E1g '
             irrname(4)='E1u '
             irrname(5)='E2g '
             irrname(6)='E2u '
             IF (soc) THEN
                char_table(7,1:6)=(/one,-one, one, one,-one, one/)
                char_table(8,1:6)=(/one,-one, one,-one, one,-one/)
                char_table( 9,1:6)=(/one,-omega, CONJG(omega),&
                     &                                one,-omega, CONJG(omega)/)
                char_table(10,1:6)=(/one,-omega, CONJG(omega),&
                     &                               -one, omega,-CONJG(omega)/)
                char_table(11,1:6)=(/one,-CONJG(omega), omega,&
                     &                                one,-CONJG(omega), omega/)
                char_table(12,1:6)=(/one,-CONJG(omega), omega,&
                     &                               -one, CONJG(omega),-omega/)
                irrname(7)="Ag' "
                irrname(8)="Au' "
                irrname(9)="E1g'"
                irrname(10)="E1u'"
                irrname(11)="E2g'"
                irrname(12)="E2u'"
             ENDIF
          ENDIF
       ELSEIF (rot(2).GT.1) THEN
          grpname='D6'
          char_table(1,1:6)=(/1.0,  1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:6)=(/1.0,  1.0,  1.0,  1.0, -1.0, -1.0/)
          char_table(3,1:6)=(/1.0, -1.0,  1.0, -1.0,  1.0, -1.0/)
          char_table(4,1:6)=(/1.0, -1.0,  1.0, -1.0, -1.0,  1.0/)
          char_table(5,1:6)=(/2.0,  1.0, -1.0, -2.0,  0.0,  0.0/)
          char_table(6,1:6)=(/2.0, -1.0, -1.0,  2.0,  0.0,  0.0/)
          irrname(1)='Gam1'
          irrname(2)='Gam2'
          irrname(3)='Gam3'
          irrname(4)='Gam4'
          irrname(5)='Gam6'
          irrname(6)='Gam5'
       ELSE
          IF (rot(6).EQ.0) THEN
             grpname='D3d'
             char_table(1,1:6)=(/1.0,  1.0,  1.0,  1.0,  1.0,  1.0/)
             char_table(2,1:6)=(/1.0,  1.0, -1.0,  1.0,  1.0, -1.0/)
             char_table(3,1:6)=(/2.0, -1.0,  0.0,  2.0, -1.0,  0.0/)
             char_table(4,1:6)=(/1.0,  1.0,  1.0, -1.0, -1.0, -1.0/)
             char_table(5,1:6)=(/1.0,  1.0, -1.0, -1.0, -1.0,  1.0/)
             char_table(6,1:6)=(/2.0, -1.0,  0.0, -2.0,  1.0,  0.0/)
             irrname(1)='A1g'
             irrname(2)='A2g'
             irrname(3)='Eg'
             irrname(4)='A1u'
             irrname(5)='A2u'
             irrname(6)='Eu'
          ELSEIF (rot(6).GT.1) THEN
             grpname='C6'
             char_table(:,:) = 0.0
             WRITE(24,*) 'C6: Character table missing in grp_k.F'
          ELSE
             IF (members(3).GT.1) grpname='D3h'    ! maybe this works
             IF (members(3).EQ.1) grpname='C6v'
             char_table(1,1:6)=(/1.0,  1.0,  1.0,  1.0,  1.0,  1.0/)
             char_table(2,1:6)=(/1.0,  1.0,  1.0,  1.0, -1.0, -1.0/)
             char_table(3,1:6)=(/1.0, -1.0,  1.0, -1.0,  1.0, -1.0/)
             char_table(4,1:6)=(/1.0, -1.0,  1.0, -1.0, -1.0,  1.0/)
             char_table(5,1:6)=(/2.0,  1.0, -1.0, -2.0,  0.0,  0.0/)
             char_table(6,1:6)=(/2.0, -1.0, -1.0,  2.0,  0.0,  0.0/)
             irrname(1)='Gam1'
             irrname(2)='Gam2'
             irrname(3)='Gam3'
             irrname(4)='Gam4'
             irrname(5)='Gam6'
             irrname(6)='Gam5'
          ENDIF
       ENDIF
    CASE(8)                           ! Th, C4h and D2h
       IF (rot(3).GT.0) THEN
          grpname='Th'
          char_table(:,:) = 0.0
          WRITE(24,*) 'Th: Character table missing in grp_k.F'
       ELSE IF (rot(2).EQ.3) THEN
          grpname='D2h'
          char_table(:,:) = 0.0
          WRITE(24,*) 'D2h: Character table missing in grp_k.F'
       ELSE
          grpname='C4h'
          char_table(:,:) = 0.0
          WRITE(24,*) 'C4h: Character table missing in grp_k.F'
       ENDIF
    CASE(10)                           ! D4h and Oh
       IF (rot(3).GT.0) THEN
          grpname='Oh'
          char_table(1,1:10)= (/1.0,  1.0,  1.0,  1.0,  1.0,&
               &                                1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:10)= (/1.0, -1.0,  1.0,  1.0, -1.0,&
               &                                1.0, -1.0,  1.0,  1.0, -1.0/)
          char_table(3,1:10)= (/2.0,  0.0, -1.0,  2.0,  0.0,&
               &                                2.0,  0.0, -1.0,  2.0,  0.0/)
          char_table(4,1:10)= (/3.0,  1.0,  0.0, -1.0, -1.0,&
               &                                3.0,  1.0,  0.0, -1.0, -1.0/)
          char_table(5,1:10)= (/3.0, -1.0,  0.0, -1.0,  1.0,&
               &                                3.0, -1.0,  0.0, -1.0,  1.0/)
          char_table(6,1:10)= (/1.0,  1.0,  1.0,  1.0,  1.0,&
               &                               -1.0, -1.0, -1.0, -1.0, -1.0/)
          char_table(7,1:10)= (/1.0, -1.0,  1.0,  1.0, -1.0,&
               &                               -1.0,  1.0, -1.0, -1.0,  1.0/)
          char_table(8,1:10)= (/2.0,  0.0, -1.0,  2.0,  0.0,&
               &                               -2.0,  0.0,  1.0, -2.0,  0.0/)
          char_table(9,1:10)= (/3.0,  1.0,  0.0, -1.0, -1.0,&
               &                               -3.0, -1.0,  0.0,  1.0,  1.0/)
          char_table(10,1:10)=(/3.0, -1.0,  0.0, -1.0,  1.0,&
               &                               -3.0,  1.0,  0.0,  1.0, -1.0/)

          irrname(1)='Gam1+'
          irrname(2)='Gam2+'
          irrname(3)='Gam3+'
          irrname(4)='Gam4+'
          irrname(5)='Gam5+'
          irrname(6)='Gam1-'
          irrname(7)='Gam2-'
          irrname(8)='Gam3-'
          irrname(9)='Gam4-'
          irrname(10)='Gam5-'
       ELSE
          grpname='D4h'
          char_table(1,1:10)= (/1.0,  1.0,  1.0,  1.0,  1.0,&
               &                                1.0,  1.0,  1.0,  1.0,  1.0/)
          char_table(2,1:10)= (/1.0,  1.0,  1.0, -1.0, -1.0,&
               &                                1.0,  1.0,  1.0, -1.0, -1.0/)
          char_table(3,1:10)= (/1.0, -1.0,  1.0,  1.0, -1.0,&
               &                                1.0, -1.0,  1.0,  1.0, -1.0/)
          char_table(4,1:10)= (/1.0, -1.0,  1.0, -1.0,  1.0,&
               &                                1.0, -1.0,  1.0, -1.0,  1.0/)
          char_table(5,1:10)= (/2.0,  0.0, -2.0,  0.0,  0.0,&
               &                                2.0,  0.0, -2.0,  0.0,  0.0/)
          char_table(6,1:10)= (/1.0,  1.0,  1.0,  1.0,  1.0,&
               &                               -1.0, -1.0, -1.0, -1.0, -1.0/)
          char_table(7,1:10)= (/1.0,  1.0,  1.0, -1.0, -1.0,&
               &                               -1.0, -1.0, -1.0,  1.0,  1.0/)
          char_table(8,1:10)= (/1.0, -1.0,  1.0,  1.0, -1.0,&
               &                               -1.0,  1.0, -1.0, -1.0,  1.0/)
          char_table(9,1:10)= (/1.0, -1.0,  1.0, -1.0,  1.0,&
               &                               -1.0,  1.0, -1.0,  1.0, -1.0/)
          char_table(10,1:10)=(/2.0,  0.0, -2.0,  0.0,  0.0,&
               &                               -2.0,  0.0,  2.0,  0.0,  0.0/)

          ! standard char-table assumes the order: E, 4, 2, 2_h, 2_h' where 4 and 2
          ! rotate around the same axis and 2_h is perpendicular to this axis. Check:

          CALL cross( rax(1,2),rax(1,3),kt )
          IF (kt(1)**2+kt(2)**2+kt(3)**2 < eps) THEN
             !                  all ok
          ELSE
             CALL cross( rax(1,2),rax(1,4),kt )
             IF (kt(1)**2+kt(2)**2+kt(3)**2 < eps) THEN      ! change 3 & 4
                CALL change_column(char_table,10,10,3,4)
                ! check, whether element 3 is perpendicular to element 2
                IF (DOT_PRODUCT(rax(1:3,2),rax(1:3,3)) < eps) THEN
                   !                     all ok
                ELSE             ! change 4 & 5
                   WRITE(*,*) DOT_PRODUCT(rax(1:3,2),rax(1:3,3))
                   CALL change_column(char_table,10,10,4,5)
                ENDIF
             ELSE
                CALL cross( rax(1,2),rax(1,5),kt )
                IF (kt(1)**2+kt(2)**2+kt(3)**2 < eps) THEN    ! change 3 & 5
                   CALL change_column(char_table,10,10,3,5)
                   IF (DOT_PRODUCT(rax(1:3,2),rax(1:3,3)) < eps) THEN ! change 4 & 5
                      CALL change_column(char_table,10,10,4,5)
                   ELSE
                      !                     all ok
                   ENDIF
                ELSE
                   CALL juDFT_error("D4h",calledby="grp_k")
                ENDIF
             ENDIF
          ENDIF
          irrname(1)='A1g'
          irrname(2)='A2g'
          irrname(3)='B1g'
          irrname(4)='B2g'
          irrname(5)='Eg'
          irrname(6)='A1u'
          irrname(7)='A2u'
          irrname(8)='B1u'
          irrname(9)='B2u'
          irrname(10)='Eu'
       ENDIF
    CASE(12)                           ! D6h and C6h
       IF (rot(2).EQ.3) THEN
          grpname='D6h'
          char_table(:,:) = 0.0
          WRITE(24,*) 'D6h: Character table missing in grp_k.F'
       ELSE
          grpname='C6h'
          char_table(:,:) = 0.0
          WRITE(24,*) 'C6h: Character table missing in grp_k.F'
       ENDIF
    CASE DEFAULT
       WRITE(24,*) 'Group of k not identified'
    END SELECT

    !>

  END SUBROUTINE grp_k
  !-------------------------------------------------------------------------------

  !<--SUBROUTINE rotaxis(alpha,beta,gamma,rax,theta)
  SUBROUTINE rotaxis(alpha,beta,gamma,rax,theta)

    ! Determines the rotation axis based on the Euler angles
    IMPLICIT NONE
    REAL, INTENT(IN) :: alpha,beta,gamma
    REAL, INTENT(OUT) :: rax(4),theta

    REAL :: costhe2,the2
    INTEGER :: i

    costhe2=COS(beta/2.0)*COS((alpha+gamma)/2.0)
    the2=ACOS(costhe2)
    rax=0.0
    IF (the2.GT.0.00001) THEN
       rax(1)=-SIN(beta/2.0)*SIN((alpha-gamma)/2.0)/SIN(the2)
       rax(2)= SIN(beta/2.0)*COS((alpha-gamma)/2.0)/SIN(the2)
       rax(3)= COS(beta/2.0)*SIN((alpha+gamma)/2.0)/SIN(the2)
    ENDIF
    DO i=1,3
       IF (ABS(rax(i)).GT.0.0001) THEN
          rax(i)=rax(i)/ABS(rax(i))
       ENDIF
    ENDDO
    rax(4)=rax(1)**2+rax(2)**2+rax(3)**2
    theta=the2*2.0
  END SUBROUTINE rotaxis
  !>

  !<--Subroutine euler
  SUBROUTINE euler(n,sym,cell,alpha,beta,gamma)

    ! determines the Euler angles corresponding the proper rotation part of mrot

    USE m_constants, ONLY : pi_const
    USE m_inv3
    USE m_types
    IMPLICIT NONE
    INTEGER,INTENT(IN)         :: n
    TYPE(t_sym),INTENT(IN)     :: sym
    TYPE(t_cell),INTENT(IN)    :: cell

    REAL, INTENT(OUT) :: alpha,beta,gamma

    INTEGER :: det
    REAL :: mprop(3,3)
    REAL :: sina,sinb,sinc,cosa,cosb,cosc
    REAL :: amatinv(3,3),detr

    CALL inv3(cell%amat,amatinv,detr)
    det= sym%mrot(1,1,n)*sym%mrot(2,2,n)*sym%mrot(3,3,n) +&
         &        sym%mrot(1,2,n)*sym%mrot(2,3,n)*sym%mrot(3,1,n) +&
         &        sym%mrot(2,1,n)*sym%mrot(3,2,n)*sym%mrot(1,3,n) -&
         &        sym%mrot(1,3,n)*sym%mrot(2,2,n)*sym%mrot(3,1,n) -&
         &        sym%mrot(2,3,n)*sym%mrot(3,2,n)*sym%mrot(1,1,n) -&
         &        sym%mrot(2,1,n)*sym%mrot(1,2,n)*sym%mrot(3,3,n)

    ! Take the proper rotation
    mprop=REAL(det)*MATMUL(cell%amat,MATMUL(REAL(sym%mrot(:,:,n)),amatinv))
    ! Euler angles
    cosb = mprop(3,3)
    sinb = 1.00 - cosb*cosb
    sinb = MAX(sinb,0.00)
    sinb = SQRT(sinb)
    !
    ! if beta = 0 or pi , only alpha+gamma or -gamma have a meaning:
    !
    IF ( ABS(sinb).LT.1.0e-5 ) THEN
       beta = 0.0
       IF ( cosb.LT.0.0 ) beta = pi_const
       gamma = 0.0
       cosa = mprop(1,1)/cosb
       sina = mprop(1,2)/cosb
       IF ( ABS(sina).LT.1.0e-5 ) THEN
          alpha=0.0
          IF ( cosa.LT.0.0 ) alpha=alpha+pi_const
       ELSE
          alpha = 0.5*pi_const - ATAN(cosa/sina)
          IF ( sina.LT.0.0 ) alpha=alpha+pi_const
       ENDIF
    ELSE
       beta = 0.5*pi_const - ATAN(cosb/sinb)
       !
       ! determine alpha and gamma from d13 d23 d32 d31
       !
       cosa = mprop(3,1)/sinb
       sina = mprop(3,2)/sinb
       cosc =-mprop(1,3)/sinb
       sinc = mprop(2,3)/sinb
       IF ( ABS(sina).LT.1.0e-5 ) THEN
          alpha=0.0
          IF ( cosa.LT.0.0 ) alpha=alpha+pi_const
       ELSE
          alpha = 0.5*pi_const - ATAN(cosa/sina)
          IF ( sina.LT.0.0 ) alpha=alpha+pi_const
       ENDIF
       IF ( ABS(sinc).LT.1.0e-5 ) THEN
          gamma = 0.0
          IF ( cosc.LT.0.0 ) gamma=gamma+pi_const
       ELSE
          gamma = 0.5*pi_const - ATAN(cosc/sinc)
          IF ( sinc.LT.0.0 ) gamma=gamma+pi_const
       ENDIF

    ENDIF

  END SUBROUTINE euler
  !>
  !-----------------------------------------------------------
  SUBROUTINE change_column( char_table,nx,ny,r1,r2 )

    INTEGER, INTENT (IN)   :: nx,ny,r1,r2
    COMPLEX, INTENT(INOUT) :: char_table(:,:)

    COMPLEX tmpc(nx)

    tmpc(1:nx) = char_table(1:nx,r1)
    char_table(1:nx,r1) = char_table(1:nx,r2)
    char_table(1:nx,r2) = tmpc(1:nx)
    tmpc(1:nx) = char_table(1:nx,r1+nx/2)
    char_table(1:nx,r1+nx/2) = char_table(1:nx,r2+nx/2)
    char_table(1:nx,r2+nx/2) = tmpc(1:nx)

  END SUBROUTINE change_column
END MODULE m_grp_k

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
      COMPLEX FUNCTION CDOTC( N, X, INCX, Y, INCY )

      INTEGER            INCX, INCY, N
      COMPLEX            X( * ), Y( * )

      COMPLEX            ZERO
      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )

      COMPLEX            CTEMP
      EXTERNAL           CDOTC_SUB

      IF( N.GT.0 ) THEN
         CALL CDOTC_SUB( N, X, INCX, Y, INCY, CTEMP )
         CDOTC = CTEMP
      ELSE
         CDOTC = ZERO
      END IF

      RETURN
      END

max_stars_repo_name: stip/FLENS

max_issues_repo_name: stip/FLENS

max_forks_repo_name: stip/FLENS


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.01/01                              *
C  *    TEST TITLE : 2D polymarker and display space       *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C marker type
      INTEGER    PPOINT,   PPLUS,   PAST,   POMARK,   PXMARK
      PARAMETER (PPOINT=1, PPLUS=2, PAST=3, POMARK=4, PXMARK=5)

C aspect source
C                bundled     individual
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

      INTEGER    NLEFT,   NRIGHT,   NBOTT,   NTOP
      PARAMETER (NLEFT=1, NRIGHT=2, NBOTT=3, NTOP=4)

      INTEGER    PICSTR, TXCI, IX, JX, NMARK
      INTEGER    RAN4(4), RAN12(12), ANSSIZ,ANSLIS(10)
      INTEGER    IDUM1,IDUM2,IDUM3,IDUM4

      REAL       XNOM(NLEFT:NRIGHT), YNOM(NBOTT:NTOP), XA(20), YA(20)
      REAL       RSIDE,LSIDE,BSIDE,TSIDE, XLOC,YLOC, XOP,YOP, XCM,YCM
      REAL       DCMAXX,DCMAXY, NOMMS, RNDRL, MRGIN, SCF
C  distance in WC from edge of display space
      PARAMETER (MRGIN = 0.004)
      REAL       RDUM1,RDUM2

      LOGICAL    APPEQ, IAREQ

      CALL INITGL ('04.01/01')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C set-up of workstation and dialogue area
      PICSTR = 101
      TXCI = 1
      CALL SETDLG (PICSTR, 801,TXCI)

      CALL POPST (PICSTR)
C  For all test cases: use individual attributes
      CALL SETASF (PINDIV)
      CALL PQPMF (SPECWT, 0, ERRIND, IDUM1,IDUM2,IDUM3, NOMMS,
     1            RDUM1,RDUM2, IDUM4)
      CALL CHKINQ ('pqpmf', ERRIND)
C  set polymarker size to 3.0mm.
      SCF = 0.003 / (NOMMS * MTRPDC)
      CALL PSMKSC (SCF)
C  thin lines
      CALL PSLWSC (0.0)
C  set view for entire display space
      CALL PSVWI (3)
      CALL PEXST (102)
      CALL PCLST

      CALL POPST (102)

      CALL SETMSG ('1', 'The location of 2D polymarkers should be ' //
     1             'determined by their associated modelling '      //
     2             'coordinates as modified by the transformation ' //
     3             'pipeline.')

C  draw outline of display space using polyline
      CALL DRWREC (0.0,1.0, 0.0,SYXRAT)
      CALL PEXST (103)
      CALL PCLST
      CALL POPST (103)

C  get display space DC-size to derive WC/DC ratio for view #3
      CALL PQDSP  (SPECWT, ERRIND, IDUM1, DCMAXX,DCMAXY, IDUM2,IDUM3)
      CALL CHKINQ ('pqdsp', ERRIND)

C  WC coordinate of right side of empty display space
      IF (SCRMOD.EQ.2) THEN
C  left edge of dialogue area
         RSIDE = 1-DSIZE
      ELSE
C  dialogue area not at right
         RSIDE = 1
      ENDIF

C  WC coordinate of bottom side of empty display space
      IF (SCRMOD.EQ.1) THEN
C  top edge of dialogue area
         BSIDE = SYXRAT*DSIZE
      ELSE
C  dialogue area not at bottom
         BSIDE = 0
      ENDIF

C  WC coordinate of left,top side of empty display space
      LSIDE = 0
      TSIDE = SYXRAT

C  for all 5 polymarker types
      DO 200 IX = PPOINT,PXMARK
C  random from 0.1 to 0.9 between lside and rside
         XLOC = RNDRL(0.1,0.9)
         XA(1) = (1-XLOC)*LSIDE + XLOC*RSIDE
C  random from 0.1 to 0.9 between bside and tside
         YLOC = RNDRL(0.1,0.9)
         YA(1) = (1-YLOC)*TSIDE + YLOC*BSIDE
C  draw marker of type ix at xloc,yloc
         CALL PSMK (IX)
         CALL PPM  (1, XA,YA)
         CALL DRLVAL ('LOCATION OF 2D POLYMARKER: Enter the '    //
     1                'distance, in centimeters, from the left ' //
     1                'edge of the display space to the center ' //
     1                'of the polymarker.', XOP)
         CALL DRLVAL ('LOCATION OF 2D POLYMARKER: Enter the '    //
     1                'distance, in centimeters, from the top '  //
     1                'edge of the display space to the center ' //
     1                'of the polymarker.', YOP)
         XCM  = 100 * MTRPDC * (XA(1)-LSIDE) * DCMAXX
         YCM  = 100 * MTRPDC * (TSIDE-YA(1)) * DCMAXX
         CALL PEMST (103)

C  must be within 0.5cm to pass ...
         IF (APPEQ (XOP,XCM, 0.5, 0.0) .AND.
     1       APPEQ (YOP,YCM, 0.5, 0.0) ) THEN
C           OK so far
         ELSE
            CALL FAIL
            GOTO 299
         ENDIF

C  next ix
200   CONTINUE
      CALL PASS

C  end_loc:
299   CONTINUE

      CALL PCLST
      CALL POPST (102)
      CALL PEMST (102)

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

      CALL SETMSG ('1 2', 'All polymarkers drawn within the display ' //
     1             'space should be visible, and all others should '  //
     2             'not be visible.')

C  set marker type to asterisk
      CALL PSMK (PAST)
C  try for different color
      CALL PSPMCI (2)
C  ran4 = ensure each side has a different number of markers, between 3 and 8
      CALL RNBSET (4, 3,8, RAN4)

C  nominal location of edges
      XNOM(NLEFT)  = MRGIN
      XNOM(NRIGHT) = 1-MRGIN
      YNOM(NBOTT)  = MRGIN
      YNOM(NTOP)   = SYXRAT-MRGIN

C  for ix = left,right,bottom,top
      DO 100 IX = NLEFT,NTOP
C  randomize 12 locations along each edge
         CALL RNPERM (12, RAN12)
C  nmark = number of markers to be drawn
         NMARK = RAN4(IX)
C  draw NMARK markers just inside edge #ix at locations ran12(1 : nmark),
C  and a few more outside
         DO 150 JX = 1,12
            IF (IX.EQ.NLEFT .OR. IX.EQ.NRIGHT) THEN
               XA(JX) = XNOM(IX)
               YA(JX) = SYXRAT * (RAN12(JX) - 0.5) / 12.0
C  move to outside, if more than NMARK
               IF (JX.GT.NMARK) XA(JX) = XA(JX) + (MRGIN * (IX*4-6))
            ELSE
               YA(JX) = YNOM(IX)
               XA(JX) = (RAN12(JX) - 0.5) / 12.0
C  move to outside, if more than NMARK
               IF (JX.GT.NMARK) YA(JX) = YA(JX) + (MRGIN * (IX*4-14))
            ENDIF

150      CONTINUE
         CALL PPM (12, XA,YA)
100   CONTINUE

110   CONTINUE

      CALL DILIST ('SIZE OF DISPLAY SPACE: Enter four numbers '    //
     1             'indicating how many markers are visible '      //
     1             'along the left, right, bottom, and top edges ' //
     1             'respectively of the entire display space.',
     1             ANSSIZ,ANSLIS)
      IF (ANSSIZ.EQ.1 .AND. ANSLIS(1).EQ.0) THEN
         CALL OPFAIL
      ELSEIF (ANSSIZ.EQ.4) THEN
         CALL IFPF (IAREQ(4, ANSLIS, RAN4))
      ELSE
         CALL OPMSGW ('List must contain exactly four numbers.')
         GOTO 110
      ENDIF
      CALL PEMST (102)

666   CONTINUE
C  wrap it up.
      CALL ENDIT
      END


text:
PROGRAM days
IMPLICIT NONE
  CHARACTER(LEN = 11) :: day  ! User input for day of the week
  !CHARACTER(LEN = 9) :: weekdays(5)
  !CHARACTER(LEN = 8) :: weekends(2)
  CHARACTER(LEN = 11) :: type ! Type of day (i.e. weekday or weekend)

  !weekdays = (/ "Monday   ", "Tuesday  ", "Wednesday", "Thursday ", "Friday   "/)
  !weekends = (/ "Saturday", "Sunday  "/)
  WRITE(*, *) "What day of the week is it today?"
  READ(*, *) day
  SELECT CASE (day)
  CASE("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
    type = "Weekday"
  CASE("Saturday","Sunday")
    type = "Weekend"
  CASE DEFAULT
    type = "Invalid day"
  END SELECT
  WRITE(*, *) day, " is a ", type
  !WRITE(*, *) weekdays

END PROGRAM days

max_stars_repo_name: evanmacbride/fortran-practice

max_issues_repo_name: evanmacbride/fortran-practice

max_forks_repo_name: evanmacbride/fortran-practice


text:
	CHARACTER*(*) FUNCTION PT_TURB  ( tpot )
C************************************************************************
C* PT_TURB								*
C*									*
C* This function converts the turbulence type number into a character   *
C* string.								*
C*									*
C* CHARACTER*(*) PT_TURB  ( TPOT )					*
C*									*
C* Input parameters:							*
C*	TPOT		REAL		Type of turbulence		*
C*									*
C* Output parameters:							*
C*	PT_TURB		CHAR*		Turbulence type symbol          *
C**									*
C* Log:									*
C* A. Hardy/GSC		7/99						*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C* A. Hardy/SAIC	10/01   Added range check ; removed unused vars *
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
        CHARACTER       cvis(3)*3
C*
        INCLUDE         'ERMISS.FNC'
        DATA   cvis / 'CAT', 'CP', 'L' /
C*
C------------------------------------------------------------------------
        PT_TURB = ' '
        iturb = NINT ( tpot )
C
C*      Check for missing data.
C
        IF  ( ERMISS ( tpot ) .or. ( iturb .lt. 1 ) .or.
     +                                        ( iturb .gt. 3 ) ) THEN
            RETURN
C
C*        Convert to character string.
C
          ELSE
            PT_TURB =  cvis (iturb)
        END IF

C*
	RETURN
	END


text:
      double complex function BSYA1fggpppp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, March 2012
C---- arXiv:1101.5947 [hep-ph], Eq. (100),fully Badger-compliant
C---- (These are twiddle functions, c.f.arXiv:1101.5947[hep-ph],Eq.(91))
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'zabprods_decl.f'
      include 'qdef.f'
      double precision s23
      integer e1,p2,p3,e4

      s23=s(p2,p3)
      BSYA1fggpppp=
     & -2d0*mt*(za(e1,e4)*zab(p2,q1,p2)-za(p2,e1)*za(p3,e4)*zb(p2,p3))
     & /(za(p2,p3)**3*zb(p2,p3))*(s23/6d0)

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
	SUBROUTINE WS_OUT  ( lunf, wtype, strtim, stptim, origin, wthr,
     +	 icor, icancl, nhdln, zones, nzone, adstn, istnm, stnnam,
     +		 stat, coun, adlat, adlon, selv, ispri,
     +		 tbchrs, nade, iret )
C************************************************************************
C* WS_OUT								*
C*									*
C* This subroutine writes the winter storm message type, start time, 	*
C* stop time, bulletin originator, weather type, correction/test flag	*
C* and cancellation flag, and zone information to an ASCII file.	*
C*									*
C* WS_OUT ( LUNF, WTYPE, STRTIM, STPTIM, ORIGIN, WTHR, ICOR, ICANCL,	*
C*	   NHDLN, ZONES, NZONE, ADSTN, ISTNM, STNNAM, STAT, COUN, ADLAT,*
C*	   ADLON, SELV, ISPRI, TBCHRS, NADE, IRET )			*
C*									*
C* Input parameters:							*
C*	LUNF		INTEGER		ASCII output file number	*
C*	WTYPE  (2)	CHAR*		Winter storm message type	*
C*	STRTIM (2)	CHAR*		Start time			*
C*	STPTIM (2)	CHAR*		Stop time			*
C*	ORIGIN		CHAR*		Bulletin originator		*
C*	WTHR   (2)	CHAR*		Weather type			*
C*	ICOR		INTEGER		Correction indicator		*
C*	ICANCL (2)      INTEGER         Cancellation flag		*
C* 	NHDLN		INTEGER		Number of headlines		*
C*	ZONES (NZONE)	CHAR*6		Zones names in storm area    	*
C*	NZONE		INTEGER		Number of zones in area		*
C*	ADSTN (*)       CHAR*           Station ID                      *
C*      ISTNM (*)       INTEGER         Station number                  *
C*      STNNAM (*)      CHAR*           Station name                    *
C*      STAT (*)        CHAR*           State ID                        *
C*      COUN (*)        CHAR*           Country ID                      *
C*      ADLAT (*)       REAL            Latitude                        *
C*      ADLON (*)       REAL            Longitude                       *
C*      SELV (*)        REAL            Elevation                       *
C*      ISPRI (*)       INTEGER         Priority number                 *
C*      TBCHRS (*)      CHAR*           Issuing station name            *
C*      NADE            INTEGER         Number of table entries         *
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return		*
C*									*
C**									*
C* Log:									*
C* M. Li/SAIC		08/02						*
C* M. Li/SAIC		02/03	Increase dim to handle 2 headlines	*
C* M. James/UCAR        05/16   gfortran 4.6+ fix for writing files     *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	wtype(*), strtim(*), stptim(*), origin, wthr(*)
	CHARACTER*(*)   zones (*), adstn (*), stnnam (*), stat (*),
     +   		coun (*), tbchrs (*)
        INTEGER         istnm (*), ispri (*), nade, icancl(*)
        REAL            adlat (*), adlon (*), selv (*)
C*
	CHARACTER       wloc*80, corr, cancl
C-----------------------------------------------------------------------
	iret = 0
C
C*	Setting up the information string.
C
	CALL ST_LSTR ( wtype(1), lenwtyp, ier )
	CALL ST_LSTR ( strtim(1), lentim, ier )
	CALL ST_INCH ( icor, corr, ier )
	CALL ST_LSTR ( origin, lenstn, ier )

       	DO ii = 1, nhdln
	   CALL ST_INCH ( icancl(ii), cancl, ier )
	   CALL ST_LSTR ( wthr(ii), lenw, ier )
	   wloc = '|' // wtype(ii)(:lenwtyp) // '|' //
     +            strtim(ii)(:lentim) // '|' // stptim(ii)(:lentim) //
     +            '|' // origin(:lenstn) //
     +    	  '|' // wthr(ii)(:lenw) // '|' // corr //
     +	          '|' // cancl
C
C*	   Write the storm information to the ASCII file.
C
	   BACKSPACE(lunf)
	   WRITE(lunf,20)wloc
 20        FORMAT (A)
C
C*	   Compare the zones ids with the zones table.
C
	   DO istn = 1, nade
	      DO icnt = 1, nzone
	        IF ( zones(icnt) .eq. adstn(istn) ) THEN
	            WRITE(lunf,100) adstn(istn), istnm(istn),
     +			    stnnam(istn), stat(istn), coun(istn),
     +			    adlat (istn), adlon (istn), selv(istn),
     +                      ispri(istn), tbchrs(istn)
 100		    FORMAT ( A, 1X, I6, 1X, A, 1X, A, 1X, A, 1X,
     +                    F9.2, 1X, F9.2, 1X, F9.2, 1X, I2, 1X, A )
		END IF
	      END DO
	   END DO
	END DO
C*
	RETURN
	END


!=============================================================================!
        subroutine itrBC3D(vl,vml)
!
!  Satisfy the boundary conditions for the 3D variables
!
!  Revised: 4-17-96
!=============================================================================!
        use global
        use stencil
        use bump
        implicit none

        complex :: vl(ndof,nx,ny)
        real :: vml(ndof,nx,ny)

!.... local variables

        real :: tmp

        real, allocatable :: rhom(:), cm(:), tm(:), um(:)
        complex, allocatable :: c1(:), c2(:), c3(:), c4(:)
        complex, allocatable :: rho(:), u1(:), u2(:), u3(:), t(:), p(:)

        complex :: ub(nx), vb(nx)

        integer :: i, j

!.... forcing parameters

        real :: a, d, kk
        complex :: ac

!=============================================================================!
!       L I N E A R   B O U N D A R Y   C O N D I T I O N S
!=============================================================================!
        if (yper) then

          vl(:,:,ny) = vl(:,:,1)

        else                    ! yper

!=============================================================================!
!       W a l l
!=============================================================================!
        if (Navier) then

!.... no slip wall

!!$     if (wall.eq.3) then   ! bump
!!$       vl(2,:,1) = u1w
!!$       vl(3,:,1) = u2w
!!$       vl(4,:,1) = u3w
!!$     else
          vl(2,is:ie,1) = zero
          vl(3,is:ie,1) = zero
          vl(4,is:ie,1) = zero
!!$     end if

!.... set drho/dy = 0 which implies dp/deta = 0

        if (wall.eq.1) then
          vl(1,is:ie,1) = -( gc2 * vl(1,is:ie,2)  + &
                         gc3 * vl(1,is:ie,3)  + &
                         gc4 * vl(1,is:ie,4)  + &
                         gc5 * vl(1,is:ie,5)  ) / gc1
        end if

!.... linear extrapolation of rho at the wall

        if (wall.eq.2) then
          vl(1,is:ie,1) = two * vl(1,is:ie,2) - vl(1,is:ie,3)
        end if

!.... Third order extrapolation to the wall for density
!.... (in computational space)

        if (wall.eq.3) then
          vl(1,is:ie,1) = 4.0*vl(1,is:ie,2) - 6.0*vl(1,is:ie,3) + &
                      4.0*vl(1,is:ie,4) - vl(1,is:ie,5)
        end if

!.... isothermal wall

        if (wallt.eq.0) then
!         if (wall.eq.3) then   ! bump
!           vl(ndof,is:ie,1) = tw
!         else
            vl(ndof,is:ie,1) = zero
!         end if
        end if

!.... adiabatic temperature ( dT/deta = 0 )

        if (wallt.eq.1) then
!         if (wall.eq.3) then   ! bump
!           if (carp) then      ! Carpenter's stencil
!             vl(ndof,is:ie,1) = ( twp - ( gg2 * vl(ndof,is:ie,2)  + &
!                               gg3 * vl(ndof,is:ie,3)  + &
!                               gg4 * vl(ndof,is:ie,4)  + &
!                               gg5 * vl(ndof,is:ie,5)  + &
!                               gg6 * vl(ndof,is:ie,6)  ) ) / gg1
!           else
!             vl(ndof,is:ie,1) = ( twp - ( gc2 * vl(ndof,is:ie,2)  + &
!                               gc3 * vl(ndof,is:ie,3)  + &
!                               gc4 * vl(ndof,is:ie,4)  + &
!                               gc5 * vl(ndof,is:ie,5)  ) ) / gc1
!           end if
!         else                  ! no bump
            if (carp) then      ! Carpenter's stencil
              vl(ndof,is:ie,1) = -( gg2 * vl(ndof,is:ie,2)  + &
                                gg3 * vl(ndof,is:ie,3)  + &
                                gg4 * vl(ndof,is:ie,4)  + &
                                gg5 * vl(ndof,is:ie,5)  + &
                                gg6 * vl(ndof,is:ie,6)  ) / gg1
            else
              vl(ndof,is:ie,1) = -( gc2 * vl(ndof,is:ie,2)  + &
                                gc3 * vl(ndof,is:ie,3)  + &
                                gc4 * vl(ndof,is:ie,4)  + &
                                gc5 * vl(ndof,is:ie,5)  ) / gc1
            end if
!         end if
        end if

        else    ! inviscid:  zero the wall-normal velocity

          ub(is:ie) = bnb(is:ie,2) * vl(2,is:ie,1) - bnb(is:ie,1) * vl(3,is:ie,1)
!         vb(is:ie) = bnb(is:ie,1) * vl(2,is:ie,1) + bnb(is:ie,2) * vl(3,is:ie,1)
          vb(is:ie) = zero

          vl(2,is:ie,1) =  bnb(is:ie,2) * ub(is:ie) + bnb(is:ie,1) * vb(is:ie)
          vl(3,is:ie,1) = -bnb(is:ie,1) * ub(is:ie) + bnb(is:ie,2) * vb(is:ie)

        end if  ! Navier
!=============================================================================!
!       T o p   B o u n d a r y
!=============================================================================!

!.... apply zero disturbance boundary condition

        if (top.eq.0) then

          vl(:,:,ny) = zero

!.... force an incomming acoustic wave

        else if (top.eq.1) then

!.... allocate room for the boundary amplitude

!         if (istep.eq.0) then
!           allocate( wamp(nx) )
!           open(66,file='amp.dat',form='formatted',status='unknown')
!           do i = 1, nx
!             read(66,*) tmp, wamp(i)
!           end do
!           close(66)
!         end if

!.... compute the characteristic amplitudes on the top boundary

          allocate( rhom(nx), tm(nx), cm(nx), um(nx), c3(nx) )

          rhom = vml(1,:,ny)
          tm   = vml(5,:,ny)
          cm   = sqrt( tm ) / Ma
          um   = vml(2,:,ny)

          d  = pt5 * ( onept33 + gamma1 / Pr ) / Re

          do i = 1, nx
            kk = omega / (cm(i)+um(i))
            a  = omega**2 * d / (cm(i)+um(i))**3
            c3(i) = exp( -a * (x(ny,i) - x0) ) * exp( im * kk * x(ny,i) )
!           c3(i) = wamp(i) * exp( im * kk * x(ny,i) )
          end do

          vl(1,:,ny) = pt5 * c3 / cm**2
          vl(2,:,ny) = c3 * pt5 / ( rhom * cm )
          vl(3,:,ny) = zero
          vl(4,:,ny) = zero
          vl(5,:,ny) = (gamma*Ma**2 * c3 * pt5 - tm * pt5 * c3 / cm**2) / rhom

          deallocate( rhom, tm, cm, um, c3 )

        end if

        end if                  ! yper

        if (xper) then

          vl(:,nx,:) = vl(:,1,:)

        else                    ! xper

!=============================================================================!
!       L e f t   B o u n d a r y
!=============================================================================!

        if (left.eq.0) then             ! zero disturbance BC

          vl(1,1,:) = zero
          vl(2,1,:) = zero
          vl(3,1,:) = zero
          vl(4,1,:) = zero
          vl(5,1,:) = zero

        else if (left.eq.4) then        ! eigenfunction inflow disturbance

          allocate( rhom(ny), tm(ny), cm(ny) )
          allocate( c1(ny), c2(ny), c3(ny), c4(ny) )
          allocate( rho(ny), u1(ny), u2(ny), u3(ny), t(ny), p(ny) )

          rhom = vml(1,1,:)
          tm   = vml(5,1,:)
          cm   = one / Ma * sqrt( tm )

!.... compute incomming characteristics (eigenfunctions)

          rho = cmplx(rhor(1:ny), rhoi(1:ny))
          u1  = cmplx(  ur(1:ny),   ui(1:ny))
          u2  = cmplx(  vr(1:ny),   vi(1:ny))
          u3  = cmplx(  wr(1:ny),   wi(1:ny))
          t   = cmplx(  tr(1:ny),   ti(1:ny))

!         p   = ( rhom * t + tm * rho ) / (gamma * Ma**2)

!         c1  = -cm**2 * rho + p                        ! entropy
!         c2  =  rhom * cm * u2                         ! vorticity
!         c3  =  rhom * cm * u1 + p                     ! right acoustic
!         c4  =  0                                      ! left acoustic

!.... update the boundary values

!         rho = ( -c1 + pt5 * ( c3 + c4 ) ) / cm**2
!         u1  = ( c3 - c4 ) * pt5 / ( rhom * cm )
!         u2  = c2 / ( rhom * cm )
!         p   = ( c3 + c4 ) * pt5
!         t   = ( gamma * Ma**2 * p - tm * rho ) / rhom

          vl(1,1,:) = rho
          vl(2,1,:) = u1
          vl(3,1,:) = u2
          vl(4,1,:) = u3
          vl(5,1,:) = t

          deallocate( rhom, tm, cm )
          deallocate( c1, c2, c3, c4 )
          deallocate( rho, u1, u2, u3, t, p )

        else if (left.eq.5) then        ! acoustic inflow disturbance

          allocate( rhom(ny), tm(ny), cm(ny), um(ny), c3(ny) )

          rhom = vml(1,1,:)
          tm   = vml(5,1,:)
          cm   = sqrt( tm ) / Ma
          um   = vml(2,1,:)

          do j = 1, ny
            kk = omega / ( cm(j)+um(j) )
            c3(j) = exp( im * kk * x(j,1) )
          end do

          vl(1,1,:) = pt5 * c3 / cm**2
          vl(2,1,:) = c3 * pt5 / ( rhom * cm )
          vl(3,1,:) = zero
          vl(4,1,:) = zero
          vl(5,1,:) = (gamma*Ma**2 * c3 * pt5 - tm * pt5 * c3 / cm**2) / rhom

          deallocate( rhom, tm, cm, um, c3 )

        else if (left.eq.7) then        ! symmetry boundary

        end if
!=============================================================================!
!       R i g h t   B o u n d a r y
!=============================================================================!

        if (right.eq.0) then            ! zero disturbance BC

          vl(1,nx,:) = zero
          vl(2,nx,:) = zero
          vl(3,nx,:) = zero
          vl(4,nx,:) = zero
          vl(5,nx,:) = zero

        else if (right.eq.4) then

          ac = (2.2804739410500E-001,-6.5163146761218E-003)
!         ac = (-2.8831962908130E-001,-1.3854663671636E-002)

          allocate( rho(ny), u1(ny), u2(ny), u3(ny), t(ny), p(ny) )

!.... compute incomming characteristics (eigenfunctions)

          rho = cmplx(rhor(:), rhoi(:)) * exp(im * ac * x(:,nx))
          u1  = cmplx(  ur(:),   ui(:)) * exp(im * ac * x(:,nx))
          u2  = cmplx(  vr(:),   vi(:)) * exp(im * ac * x(:,nx))
          u3  = cmplx(  wr(:),   wi(:)) * exp(im * ac * x(:,nx))
          t   = cmplx(  tr(:),   ti(:)) * exp(im * ac * x(:,nx))

          vl(1,nx,:) = rho
          vl(2,nx,:) = u1
          vl(3,nx,:) = u2
          vl(4,nx,:) = u3
          vl(5,nx,:) = t

          deallocate( rho, u1, u2, u3, t, p )

        else if (right.eq.5) then

!.... compute the characteristic amplitudes on the right boundary

          allocate( rhom(ny), tm(ny), cm(ny), um(ny), c3(ny) )

          rhom = vml(1,nx,:)
          tm   = vml(5,nx,:)
          cm   = sqrt( tm ) / Ma
          um   = vml(2,nx,:)

          do j = 1, ny
            kk = omega / ( cm(j)+um(j) )
            c3(j) = exp( im * kk * x(j,nx) )
          end do

          vl(1,nx,:) = pt5 * c3 / cm**2
          vl(2,nx,:) = c3 * pt5 / ( rhom * cm )
          vl(3,nx,:) = zero
          vl(4,nx,:) = zero
          vl(5,nx,:) = (gamma*Ma**2 * c3 * pt5 - tm * pt5 * c3 / cm**2) / rhom

          deallocate( rhom, tm, cm, um, c3 )

        else if (right .eq. 9) then      ! extrapolation

          vl(:,nx,:) = exp( two * log(vl(:,nx-1,:)) - log(vl(:,nx-2,:)) )

        end if

        end if                  ! xper

        return
        end


text:
      INCLUDE 'VICMAIN_FOR'

C     VAX CONVERSION BY ASM, JAN 1984
C     REVISION TO HANDLE F2 BEING CONVERTED TO VICAR2
C     ADD 'NOCENTER OPTION    -- REA 4JUN86
C     TWEAKED TO PREVENT DIVIDE BY 0 FOR FLAT IMAGES.  UNCOMMENTED HISTOGRAM
C     PRINTING.               -- SXP 17SEP90
C     MSTP S/W Conversion (VICAR Porting)      CRI    10-JUL-95
C     14-Sep-2011 -lwk- added 'NSAMPS' to XVREADs to cover cases where NS<NSIN
C
C**********************************************************************
C
      SUBROUTINE MAIN44
      INCLUDE 'pgminc'        ! TAE CONSTANTS & PARAMETERS
      EXTERNAL RAT,DIFF,LNRAT,LNDIFF
      REAL 	RPAR(2)
      REAL*8	VAL0,VAL255,OFF,GAIN
      INTEGER 	IPAR(4),IPOP(500),JPOP(500),PARB(xprdim)
      LOGICAL 	XVPTST, QLOG,QDIFF,QDISP,QFILT,QCENTER
      character*50 unconfmt
      character*50 func, FUNCSTR
      EQUIVALENCE (FUNC,FUNCSTR)
      COMMON ISL,ISS,NL,NS,INC,ATM1,ATM2,BOTTOM,SCALE,INP1,INP2,IPOP
      VALUE(I) = FLOAT(I-1)/SCALE+BOTTOM       ! intrinsic function
C
      CALL IFMESSAGE('RATIO version 14-SEP-2011')
C
      CALL XVEACTION('SA',' ')
C
C	OPEN INPUT DATASETS
C
      CALL XVUNIT(INP1,'INP',1,ISTATUS,' ')
      write(func,'(i4)') istatus
      CALL CHKSTAT(ISTATUS,' XVUNIT FAILED FOR FIRST INPUT DATASET',-1)
      CALL XVOPEN(INP1,ISTATUS,'U_FORMAT','REAL',' ')
      CALL XVUNIT(INP2,'INP',2,ISTATUS,' ')
      CALL CHKSTAT(ISTATUS,' XVUNIT FAILED FOR SECOND INPUT DATASET',-1)
      CALL XVOPEN(INP2,ISTATUS,'U_FORMAT','REAL',' ')
      CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
C
C     GET AND PROCESS THE PARAMETERS
C
      QLOG = XVPTST('LOG')
      QDISP = .NOT.XVPTST('NODISPLA')
      QFILT = .NOT.XVPTST('NOFILTER')
      QDIFF = XVPTST('DIFFEREN')
      QCENTER = XVPTST('CENTER')
C							INCLUDE
      CALL XVPARM('INCLUDE',RPAR,NUM,IND,2)
      IF (QDIFF.AND.IND.NE.0) THEN
	  BOTTOM = -249.5
	  TOP = 250.5
      ELSE
	  BOTTOM = MIN(RPAR(1),RPAR(2))
	  TOP = MAX(RPAR(1),RPAR(2))
      END IF
C							ATMOSPHERIC CORRECTIONS
      CALL XVPARM('ATM1',ATM1,NUM,IND,1)
      CALL XVPARM('ATM2',ATM2,NUM,IND,1)
C							PERCENT SATURATION
      CALL XVPARM('PERCENT',SAT,NUM,IND,1)
      SAT = 0.01*SAT
C							THRESHOLD
      CALL XVPARM('THRESHOL',THRESH,NUM,IND,1)
      THRESH = 0.01*THRESH
C							SUBSAMPLING PARAMS
      CALL XVPARM('SAMPLE',SUBSAMP,NUM,IND,1)
      INC = 1.0/(0.01*SUBSAMP)
      CALL XVPARM('LINC',LINC,NUM,IND,1)
      IF (IND.EQ.0) INC=LINC
      IF (INC.LE.0) INC=1
C							AREA
      CALL XVPARM('AREA',IPAR,NUM,IND,4)
      IF (IND.EQ.0) THEN
	  ISL = IPAR(1)
	  ISS = IPAR(2)
	  NL = IPAR(3)
	  NS = IPAR(4)
      END IF
C
C	IF GIVEN PARAMETERS ARE UNREASONABLE, ADJUST THEM
C
      IF(QLOG.AND.TOP.LT.0.0) TOP=250.5
      IF(QLOG.AND.BOTTOM.LT.-255.) BOTTOM=-255.0
      IF(QLOG.AND..NOT.QDIFF.AND.BOTTOM.LE.0.0) BOTTOM=0.2
      IF(QLOG.AND.QDIFF) ATM1=ATM1+256.0
C
      II = 4*NS
      JJ = II
      CALL ZIA(IPOP,500)
      IF(QLOG) THEN
	  IF(.NOT.QDIFF) THEN
C                                                     LOG RAT
	      BOTTOM = ALOG(BOTTOM)
	      SCALE = 500.0/(ALOG(TOP)-BOTTOM)
	      CALL STACKA(4,LNRAT,2,II,JJ)
	  ELSE
C                                                     LOG DIFF
	      BOTTOM = ALOG(BOTTOM+256.0)
	      SCALE = 500.0/(ALOG(TOP+256.0)-BOTTOM)
              CALL STACKA(4,LNDIFF,2,II,JJ)
	  END IF
C                                                     RAT & DIFF
      ELSE
          SCALE = 500.0/(TOP-BOTTOM)
          IF(QDIFF) CALL STACKA(4,DIFF,2,II,JJ)
          IF(.NOT.QDIFF) CALL STACKA(4,RAT,2,II,JJ)
      END IF
C
C     FIND MAXIMUM POPULATED BIN; FILTER HISTOGRAM IF REQUESTED
C
      IF(.NOT.QFILT) THEN
          CALL MVE(4,500,IPOP,JPOP,1,1)
          MAXMUM = 0
          DO I=1,500
              MAXMUM = MAX(MAXMUM,IPOP(I))
	  END DO
      ELSE
          JPOP(3) = IPOP(1)+IPOP(2)+IPOP(3)+IPOP(4)+IPOP(5)
          JPOP(2) = JPOP(3)-IPOP(5)+IPOP(1)
          JPOP(1) = JPOP(2)-IPOP(4)+IPOP(2)
          MAXMUM = MAX(JPOP(1),JPOP(2),JPOP(3))
          DO  I=4,498
              JPOP(I) = JPOP(I-1)-IPOP(I-3)+IPOP(I+2)
              MAXMUM = MAX(MAXMUM,JPOP(I))
	  END DO
          JPOP(499) = JPOP(498)-IPOP(496)+IPOP(500)
          JPOP(500) = JPOP(499)-IPOP(497)+IPOP(499)
          MAXMUM = MAX(MAXMUM,JPOP(499),JPOP(500))
      END IF
C
C     ZERO OUT ALL BINS POPULATED BELOW THRESHOLD LEVEL;
C     COMPUTE THE MEAN
C
      ICUT = FLOAT(MAXMUM)*THRESH+0.5
      ISUM = 0
      IWT = 0
      DO I=1,500
          IF(JPOP(I).LT.ICUT) JPOP(I)=0
          ISUM = ISUM+JPOP(I)
          IWT = IWT+JPOP(I)*I
      END DO
      MEAN = FLOAT(IWT)/FLOAT(ISUM)+0.5
C
C     COMPUTE THE HIGH AND LOW BINS THAT CORRESPOND TO THE REQUESTED
C     SATURATION LEVEL
C
      N = 0
      NSAT = MAX(ISUM*SAT,1.0)
      I=1
      DO WHILE (I.LE.500 .AND. N.LT.NSAT)
          N = N+JPOP(I)
          I=I+1
      END DO
      IF (N.LT.NSAT) CALL MABEND('SATURATION GREATER THAN 100 PERCENT')
      LOW = I-1
      N = 0
      I=1
      DO WHILE (I.LE.500 .AND. N.LT.NSAT)
          N = N+JPOP(501-I)
          I=I+1
      END DO
      IF (N.LT.NSAT) CALL MABEND('SATURATION GREATER THAN 100 PERCENT')
      IHI = 502-I
C
C     IF NEEDED, FORCE THE MEAN TO BE CENTERED (OUTPUT DN=128)
C     BY DECREASING THE SATURATION AT ONE END.
C
      IF (QCENTER) THEN
          M = MEAN-LOW
          N = IHI-MEAN
          IF(N.GT.M) LOW=MEAN-N
          IF(M.GT.N) IHI=MEAN+M
      END IF
C
C     COMPUTE THE GAIN AND OFFSET;  IF REQUESTED, CALL DISPLY TO
C     PRINT OUT THE HISTOGRAM
C
      VAL0 = VALUE(LOW)
      VAL255 = VALUE(IHI)

C...TWEAK FOR FLAT IMAGES TO PREVENT DIVIDE BY 0.

      IF ( VAL0 .EQ. VAL255)  THEN
         DELTA = VAL0 * .01
         IF (DELTA .EQ. 0)  DELTA=.01
         VAL0 = VAL0 - DELTA
         VAL255 = VAL255+DELTA
      END IF

      GAIN = 255.0/(VAL255-VAL0)
      OFF = -GAIN*VAL0
      IF(QDISP) CALL DISPLY(SCALE,BOTTOM,LOW,MEAN,IHI,JPOP,MAXMUM,
     +    QDIFF,QLOG)
C
C     GENERATE THE STRING THAT CONTAINS THE FUNCTION TO BE PASSED TO F2.
C
      func=' '
      M = 7-DLOG10(GAIN)
      FUNC(1:1) = '"'
      write(unconfmt,'(''(f10.'',i4.4,'')'')') m
      write(func(2:11),unconfmt) gain
      func(12:12) = '*'
      N = 13
      IF (QLOG) THEN
	  func(N:N+3) = 'ALOG'
	  N = N+4
      END IF
      FUNC(N:N) = '('
      N = N+1
      IF (ATM1.EQ.0.0) THEN
	      FUNC(N:N+2) = 'IN1'
	      N = N+3
	  ELSE
	      FUNC(N:N+3) = '(IN1'
	      write(FUNC(N+9-5:N+9),'(f6.1)') ATM1
	      IF (ATM1.GT.0.0) FUNC(N+4:N+4) = '+'
	      FUNC(N+10:N+10) = ')'
	      N = N+11
      END IF
      IF (QDIFF) THEN
	      FUNC(N:N) = '-'
	  ELSE
	      FUNC(N:N) = '/'
      END IF
      N = N+1
      IF (ATM2.EQ.0.0) THEN
	      FUNC(N:N+2) = 'IN2'
	      N = N+3
	  ELSE
	      FUNC(N:N+3) = '(IN2'
	      write(FUNC(N+9-5:N+9),'(f6.1)') ATM2
	      IF (ATM2.GT.0.0) FUNC(N+4:N+4) = '+'
	      FUNC(N+10:N+10) = ')'
	      N = N+11
      END IF
      FUNC(N:N) = ')'
      M = DLOG10(ABS(OFF)+1)+4
      write(unconfmt,'(''(f'',i4.4,''.1)'')') m
      write(FUNC(N+M-(M)+1:N+M),unconfmt) OFF
      IF (OFF.GE.0.0) FUNC(N+1:n+1)='+'
      FUNC(N+M+1:N+M+1) = '"'
      CALL XVMESSAGE('The ratio function is: ',' ' )
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(FUNC,' ')
      CALL XVMESSAGE(' ',' ')
C
C	SEND THE FUNCTION BACK TO THE PARAMETER 'FUNC' FOR F2
C
      CALL XQINI(PARB,xprdim,xabort)
      CALL XQSTR(PARB,'FUNC',1,FUNCSTR,xadd,ISTATUS)
      CALL XVQOUT(PARB,ISTATUS)
C
      RETURN
      END
C
C
C**********************************************************************
C
      SUBROUTINE RAT(XARR,II,YARR,JJ)
C
C     ROUTINE FOR FORMING RATIO HISTOGRAMS
C
      REAL XARR(II),YARR(JJ)
      INTEGER IPOP(500)
      COMMON ISL,ISS,NL,NS,INC,ATM1,ATM2,BOTTOM,SCALE,INP1,INP2,IPOP
      IF(JJ.NE.II) CALL MABEND('0INSUFFICIENT ROOM FOR STACKA BUFFERS')
      DO I=ISL,ISL+NL-1,INC
	  CALL XVREAD(INP1,XARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
	  CALL XVREAD(INP2,YARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
          DO J=1,NS
              X = XARR(J)+ATM1
              Y = YARR(J)+ATM2
              IF (Y.NE.0.0) THEN
	          N = SCALE*(X/Y-BOTTOM)+1.0
	          IF(N.GE.1.AND.N.LE.500) IPOP(N) = IPOP(N)+1
	      END IF
	  END DO
      END DO
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE DIFF(XARR,II,YARR,JJ)
C
C     ROUTINE FOR FORMING DIFFERENCE HISTOGRAMS
C
      REAL XARR(II),YARR(JJ)
      INTEGER IPOP(500)
      COMMON ISL,ISS,NL,NS,INC,ATM1,ATM2,BOTTOM,SCALE,INP1,INP2,IPOP
      IF(JJ.NE.II) CALL MABEND('INSUFFICIENT ROOM FOR STACKA BUFFERS')
      OFFSET = ATM1-ATM2-BOTTOM
      DO I=ISL,ISL+NL-1,INC
	  CALL XVREAD(INP1,XARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
	  CALL XVREAD(INP2,YARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
          DO J=1,NS
	      N = SCALE*(XARR(J)-YARR(J)+OFFSET)+1.0
	      IF(N.GE.1.AND.N.LE.500) IPOP(N) = IPOP(N)+1
	  END DO
      END DO
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE LNRAT(XARR,II,YARR,JJ)
C
C     ROUTINE FOR FORMING LOG RATIO HISTOGRAMS
C
      REAL XARR(II),YARR(JJ)
      INTEGER IPOP(500)
      COMMON ISL,ISS,NL,NS,INC,ATM1,ATM2,BOTTOM,SCALE,INP1,INP2,IPOP
      IF(JJ.NE.II) CALL MABEND('0INSUFFICIENT ROOM FOR STACKA BUFFERS')
      DO I=ISL,ISL+NL-1,INC
	  CALL XVREAD(INP1,XARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
	  CALL XVREAD(INP2,YARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
          DO J=1,NS
              X = XARR(J)+ATM1
              Y = YARR(J)+ATM2
              IF (X.GT.0.0.AND.Y.GT.0.0) THEN
	          N = SCALE*(ALOG(X/Y)-BOTTOM)+1.0
	          IF(N.GE.1.AND.N.LE.500) IPOP(N) = IPOP(N)+1
	      END IF
	  END DO
      END DO
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE LNDIFF(XARR,II,YARR,JJ)
C
C     ROUTINE FOR FORMING LOG DIFFERENCE HISTOGRAMS
C
      REAL XARR(II),YARR(JJ)
      INTEGER IPOP(500)
      COMMON ISL,ISS,NL,NS,INC,ATM1,ATM2,BOTTOM,SCALE,INP1,INP2,IPOP
      IF(JJ.NE.II) CALL MABEND('INSUFFICIENT ROOM FOR STACKA BUFFERS')
      OFFSET = ATM1-ATM2
      DO I=ISL,ISL+NL-1,INC
	  CALL XVREAD(INP1,XARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
	  CALL XVREAD(INP2,YARR,ISTATUS,'LINE',I,'NSAMPS',NS,' ')
          DO J=1,NS
	      N = SCALE*(ALOG(XARR(J)-YARR(J)+OFFSET)-BOTTOM)+1.0
	      IF(N.GE.1.AND.N.LE.500) IPOP(N) = IPOP(N)+1
	  END DO
      END DO
      RETURN
      END
C
C**********************************************************************
C
      SUBROUTINE DISPLY(SCALE,BOTTOM,LOW,MEAN,IHI,JPOP,MAXMUM,QDIFF,
     +                     QLOG)
C
C     ROUTINE FOR PRINTING HISTOGRAMS
C     IF FILTERING WAS PERFORMED, THIS IS THE FILTERED HISTOGRAM.
C
      INTEGER JPOP(500)
      character*132 buf, GRID
      LOGICAL QDIFF,QLOG                    !GRID(101)
      GRID=' '
      DO II=1,101,10
          GRID(II:II)='+'
      END DO
C
      BOTTOM = BOTTOM+0.5/SCALE
C
C     PRINT THE PROPER HEADING
C
      CALL XVMESSAGE(' ',' ')
      IF(.NOT.QDIFF.AND..NOT.QLOG) CALL XVMESSAGE('R A T I O',' ')
      IF(.NOT.QDIFF.AND.QLOG) CALL XVMESSAGE('L O G   R A T I O',' ')
      IF(QDIFF.AND..NOT.QLOG) CALL XVMESSAGE('D I F F E R E N C E',' ')
      IF(QDIFF.AND.QLOG) CALL XVMESSAGE('L O G   D I F F E R E N C E',
     +                                   ' ')
      buf(1:122) = ' '
      DO ii=0,100,10
          write(buf(22+ii-2:22+ii),'(i3)') ii
      END DO
c      BUF(1:1)='0'
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(' ',' ')
      CALL XVMESSAGE(BUF(1:122),' ')
      BUF(1:22) = ' '
C      CALL MVLC(GRID,BUF(23:123),101)
      BUF(22:122)=GRID(1:101)
C
C     PRINT A LINE FOR EACH POPULATED BIN, NORMALIZED TO THE MAXIMUM
C     POPULATED BIN
C
      DO I=1,500
          IF(JPOP(I).NE.0) THEN
	      X = FLOAT(I-1)/SCALE+BOTTOM
              write(buf(1:12),'(f12.3)') X
C
C     LABEL THE MEAN (OUTPUT=128DN) AND SATURATION LEVEL BINS.  IN SOME
C     CASES, ONE OF '0DN' AND '255DN' WILL BE OUTSIDE THE POPULATED RANG
C     OF THE HISTOGRAM, AND WILL NOT APPEAR.
C
              IF(I.EQ.LOW) buf(17:19) = '0DN'
      	      IF(I.EQ.MEAN) buf(16:19) = 'MEAN'
	      IF(I.EQ.IHI) buf(15:19) = '255DN'
	      BUF(22:122)=GRID(1:101)
	      N = (100*JPOP(I))/MAXMUM+1
	      do ic=22,22+N-1
		buf(ic:ic)='*'
	      enddo
              CALL XVMESSAGE(BUF(1:122),' ')
              buf(15:19) = '     '
	    ELSE IF (I.NE.1 .AND. JPOP(I-1).NE.0) THEN
	      CALL XVMESSAGE(' ',' ')
	  END IF
      END DO
      CALL XVMESSAGE(' ',' ')
      RETURN
      END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
!! SR104042: Fixed in 6.2 build 6239
!!
!! WRONG RESULT FROM NORM2 WITH REAL64 ARRAY SECTION ARGUMENT
!!
!! This is an alteration of nag-20190831.f90 which still fails after the
!! fix in build 6238 for the latter test case.
!!
!! The following example norm2 should return sqrt(91) but instead returns
!! sqrt(30) for a real64 array, but the correct result for real32.
!!
!! $ nagfor nag-20190906.f90
!! NAG Fortran Compiler Release 6.2(Chiyoda) Build 6238
!! [NAG Fortran Compiler normal termination]
!! $ ./a.out
!! STOP: 1
!!

double precision x(0:3,0:4)
x = 0
x(1:2,1:3) = reshape([1,2,3,4,5,6], shape=[2,3])
if (norm2(x(1:2,1:3)) /= sqrt(91.0d0)) stop 1  ! WRONG NORM2 RESULT
end

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


program mpi_tutorial

    ! Modules
    use mpi
    use hello_world_mod

    ! Variables
    implicit none
    integer :: rank, mpi_size, ierror!, tag, status(MPI_STATUS_SIZE)

    ! Initialize MPI
    call MPI_INIT(ierror)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, mpi_size, ierror)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierror)

    ! Main Funcion Calls
!    write(*,"(A,I11,A,I11)") "Hello World from node", rank, " of ", mpi_size
    call hello_world(rank,mpi_size)

    ! End MPI
    call MPI_FINALIZE(ierror)

end program mpi_tutorial


text:
!
!   FnVFFRetJ.f90
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFFRetJ(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

cons=gliq-FnQb(bsav,0.0d0)*bsav

if(cons .GT. cmin) then

    FnVFFRetJ = -1.0d0*(urent(cons,GridHR(1),gij)-xi+ubequest(bsav))

else

FnVFFRetJ = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFFRetJ

max_stars_repo_name: lnsongxf/housing-boom-bust

max_issues_repo_name: floswald/housing-boom-bust

max_forks_repo_name: kurtmitman/housing-boom-bust