! Copyright (c) 2015-2021, the ELSI team.
! All rights reserved.
!
! This file is part of ELSI and is distributed under the BSD 3-clause license,
! which may be found in the LICENSE file in the ELSI root directory.

!>
!! Provide stub routines which are only compiled when the actual MAGMA is not
!! available.
!!
module ELSI_MAGMA

   use ELSI_DATATYPE, only: elsi_param_t,elsi_basic_t
   use ELSI_PRECISION, only: r8

   implicit none

   private

   public :: elsi_init_magma
   public :: elsi_cleanup_magma
   public :: elsi_solve_magma

   interface elsi_solve_magma
      module procedure elsi_solve_magma_real
      module procedure elsi_solve_magma_cmplx
   end interface

contains

subroutine elsi_init_magma(ph)

   implicit none

   type(elsi_param_t) :: ph

end subroutine

subroutine elsi_solve_magma_real(ph,bh,ham,ovlp,eval,evec)

   implicit none

   type(elsi_param_t) :: ph
   type(elsi_basic_t) :: bh
   real(kind=r8) :: ham(bh%n_lrow,bh%n_lcol)
   real(kind=r8) :: ovlp(bh%n_lrow,bh%n_lcol)
   real(kind=r8) :: eval(ph%n_basis)
   real(kind=r8) :: evec(bh%n_lrow,bh%n_lcol)

   write(*,"(A)") "**Error! A MAGMA stub routine was called"
   stop

end subroutine

subroutine elsi_solve_magma_cmplx(ph,bh,ham,ovlp,eval,evec)

   implicit none

   type(elsi_param_t) :: ph
   type(elsi_basic_t) :: bh
   complex(kind=r8) :: ham(bh%n_lrow,bh%n_lcol)
   complex(kind=r8) :: ovlp(bh%n_lrow,bh%n_lcol)
   real(kind=r8) :: eval(ph%n_basis)
   complex(kind=r8) :: evec(bh%n_lrow,bh%n_lcol)

   write(*,"(A)") "**Error! A MAGMA stub routine was called"
   stop

end subroutine

subroutine elsi_cleanup_magma(ph)

   implicit none

   type(elsi_param_t) :: ph

end subroutine

end module ELSI_MAGMA


text:
	SUBROUTINE GD_SWRT ( iacss, wrtflg, iret )
C************************************************************************
C* GD_SWRT								*
C*									*
C* This subroutine sets the internal write flag for a grid file.  If	*
C* the file is being changed from READ ONLY to WRITE access, DM_CHNG	*
C* will close it and reopen it for WRITE access.			*
C*									*
C* GD_SWRT ( IACSS, WRTFLG, IRET )					*
C*									*
C* Input parameters:							*
C*	IACSS 		INTEGER		Grid acess  number		*
C*	WRTFLG		LOGICAL		Write flag			*
C*					  T = write			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC		 8/90						*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* R. Tian/SAIC          1/04   Added GD_FCHK call                      *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GMBDTA.CMN'
	INCLUDE		'grdcmn.cmn'
C*
	LOGICAL		wrtflg, shrflg
C------------------------------------------------------------------------
	iret   = 0
	shrflg = .false.
C
C*      Convert access number to DM number.
C
        CALL GD_FCHK ( iacss, igdfln, iret )
        IF ( iret .ne. 0 ) THEN
            RETURN
        END IF
C
C*	Set the flag in GRDCMN.CMN.
C
	gdwrt ( igdfln ) = wrtflg
C*
	CALL DM_CHNG ( igdfln, wrtflg, shrflg, iret )
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
	SUBROUTINE LC_ABND  ( area, iartyp, rlatll, rlonll, rlatur,
     +			      rlonur, stn, nstn, stcn, cdproj, cenlat,
     +			      cenlon, iret )
C************************************************************************
C* LC_ABND								*
C*									*
C* This subroutine translates a GEMPAK subarea.  For area types 1-3,	*
C* the latitude/longitude bounds are returned.  For area type 1, CDPROJ	*
C* contains the default projection string, and CENLAT & CENLON contain	*
C* the centroid location.  For area type 2, STN	contains the center	*
C* station.  For area type 6, STN contains the list of stations.  For	*
C* area types 5 and 7, the state or country is returned in STCN.  Area	*
C* types 2 and 3 may be followed by a number of * or - to contract or	*
C* expand the region.							*
C*									*
C* LC_ABND  ( AREA, IARTYP, RLATLL, RLONLL, RLATUR, RLONUR, STN, NSTN,	*
C*            STCN, CDPROJ, CENLAT, CENLON, IRET )			*
C*									*
C* Input parameters:							*
C*	AREA		CHAR*		Area name			*
C*									*
C* Output parameters:							*
C*	IARTYP		INTEGER		Area type 			*
C*					  -1 = none			*
C*					   1 = area name 		*
C*					   2 = center on station 	*
C*					   3 = lat/lon bounds 		*
C*					   4 = DSET 	 		*
C*					   5 = @ST	 		*
C*					   6 = @STN1;...;STNN		*
C*					   7 = @CN:C			*
C*	RLATLL		REAL		Lower left latitude		*
C*	RLONLL		REAL		Lower left longitude		*
C*	RLATUR		REAL		Upper right latitude		*
C*	RLONUR		REAL		Upper right longitude		*
C*	STN  (NSTN)	CHAR*		Stations			*
C*	NSTN		INTEGER 	Number of stations 		*
C*	STCN		CHAR*		State/country			*
C*	CDPROJ		CHAR*		Default projection string	*
C*	CENLAT		REAL		Centroid latitude		*
C*	CENLON		REAL		Centroid longitude		*
C*	IRET		INTEGER		Return code			*
C*					   0 = area found		*
C*					  -1 = invalid area name	*
C*					  -3 = station file open error	*
C**									*
C* Log:									*
C* I. Graffman/CSC	 3/82	Original 				*
C* M. Koslowski/CSC	 4/83	Modified to accept stations, * and - 	*
C* M. Goodman/RDS       12/84   Fixed @xx processing			*
C* M. desJardins/GSFC	 4/86	Removed sort of latitudes,longitudes	*
C* I. Graffman/RDS	11/87	Added :C for country			*
C* I. Graffman/RDS	 5/88	Remove STNLST				*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* M. desJardins/GSFC	 8/88	Added #clat;clon;dlat;dlon		*
C* L. Williams/EAI	 5/94	Added "+" symbol to zoom factor		*
C* S. Jacobs/NMC	 7/94	Added SFSTBL to call to LC_FSTN		*
C* D. Keiser/GSC	12/95	Changed SFSTBL to 'sfstns.tbl'		*
C* G. Krueger/EAI	 6/96	Add corner points, default projection	*
C* K. Tyle/GSC		 7/96	Added case for AREA = GAREA		*
C* M. James/UCAR	 9/14	Construct 4-char IACO from 3-char	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
	CHARACTER*(*)	area, stn(*), stcn, cdproj
C*
	REAL		rltln (4)
	CHARACTER	loc*132, c*1
C------------------------------------------------------------------------
C*	Initialize.
C
	iartyp   = -1
	rlatll   = 0.0
	rlonll   = 0.0
	rlatur   = 0.0
	rlonur   = 0.0
	iret     = -1
	stn(1)   = ' '
	stcn     = ' '
	nstn     = 0
	cdproj   = ' '
	cenlat   = 0.0
	cenlon   = 0.0
C
C*	Translate area name to upper case and find length.
C
	CALL ST_LCUC  ( area, loc, ier )
	CALL ST_LSTR  ( loc, lens, ier )
C
C*	No name was entered if length of string was 0.
C
	IF  ( lens .eq. 0 )  RETURN
C
C*	Check to see if DS or DSET was entered.
C
	IF  ( ( loc .eq. 'DS' ) .or. ( loc .eq. 'DSET' ) )  THEN
	    rlatll = -90.
	    rlonll = -180.
	    rlatur = 90.
	    rlonur = 180.
	    iartyp = 4
	    iret   = 0
	    RETURN
	ELSE IF ( loc .eq. 'GAREA' ) THEN
	    CALL GQBND ( 'M', rlatll, rlonll, rlatur, rlonur, iret )
	    iartyp = 1
	    RETURN
	ENDIF
C
C*	Check if latitudes and longitudes were explicitly entered.
C*	If the first character is #, then clat;clon;dlat;dlon were
C*	entered.
C*	Code to sort latitudes and longitudes removed to allow drawing
C*	world maps.
C
	IF  ( loc (1:1) .eq. '#' )  THEN
	    is = 2
	  ELSE
	    is = 1
	END IF
	CALL ST_RLST  ( loc (is:), ';', RMISSD, 4, rltln, num, ier )
	IF  ( ( ier .eq. 0 ) .and. ( num .eq. 4 ) )  THEN
	    IF  ( is .eq. 1 )  THEN
		rlatll = rltln (1)
		rlonll = rltln (2)
		rlatur = rltln (3)
		rlonur = rltln (4)
		cenlat = (rlatll + rlatur) / 2.
		cenlon = (rlonll + rlonur) / 2.
	      ELSE
		rlatll = rltln (1) - rltln (3)
		rlatur = rltln (1) + rltln (3)
		rlonll = rltln (2) - rltln (4)
		rlonur = rltln (2) + rltln (4)
		cenlat = rltln (1)
		cenlon = rltln (2)
	    END IF
	    IF ( cenlat .gt. 25. ) THEN
		cdproj = 'NPS'
	    ELSE IF ( cenlat .lt. -25. ) THEN
		cdproj = 'SPS'
	    ELSE
		cdproj = 'MER'
	    END IF
	    iartyp = 3
	    iret   = 0
	    RETURN
	ENDIF
C
C*	Check for @ followed by state or station list.
C
	IF  ( loc (1:1) .eq. '@' )  THEN
C
C*	    Check if the 2:3 characters are numbers
C
	    CALL ST_CRNM  ( loc (2:3), stnum, ierr )
C
C*	    If 3 characters total were entered, this is @ST.
C
	    IF  ( ( lens .eq. 3 ) .and. ( ierr .ne. 0 ) )  THEN
	        iartyp = 5
	        iret   = 0
	        stcn   = loc (2:3)
	        RETURN
C
C*		Check for @CN:C.
C
	      ELSE IF  ( ( lens .eq. 5 ) .and. ( ierr .ne. 0 ) .and.
     +			 ( loc (4:5) .eq. ':C' ) )  THEN
		iartyp = 7
		iret   = 0
		stcn   = loc (2:3)
		RETURN
C
C*	  	Otherwise, this is a station list.
C
	      ELSE
C
C*		Note that a maximum of LLMXST stations will be read.
C
		CALL ST_CLST  ( loc (2:), ';', ' ', LLMXST, stn, nstn,
     +				ier )
	        iartyp = 6
	        iret   = 0
	        RETURN
	    END IF
	END IF
C
C*	Have eliminated special cases.  Now find area using area name.
C
C*	Check for zoom factors.
C
	izoom = 0
	i     = lens
	c     = loc (i:i)
C
	DO WHILE  ( ( c .eq. '*' ) .or. ( c .eq. '-' ) .or.
     +		    ( c .eq. '+' ) )
	    IF  ( ( c .eq. '*' ) .or. ( c .eq. '+' ) )
     +		izoom = izoom + 1
	    IF  ( c .eq. '-' )  izoom = izoom - 1
	    loc  (i:i) = ' '
	    i = i - 1
	    IF  ( i .gt. 0 )  THEN
		c = loc (i:i)
	      ELSE
		c = ' '
	    ENDIF
	ENDDO
C
C*	Check for area in the geographic file list.
C
	CALL TB_FGEO  ( loc, tlatll, tlonll, tlatur, tlonur, cdproj,
     +			cenlat, cenlon, ier )
	IF  ( ier .eq. 0 )  THEN
	    iartyp = 1
	    iret   = 0
	ELSE
C
C*	    Check for area in the station file.
C

	    CALL LC_FSTN  ( 'sfstns.tbl', loc, cenlat, cenlon, ier )
	    IF  ( ier .eq. 0 )  THEN
		diflat = 4.0
		diflon = 7.0
		iartyp = 2
		stn(1) = loc
		IF ( cenlat .gt. 25. ) THEN
		    cdproj = 'NPS'
		ELSE IF ( cenlat .lt. -25. ) THEN
		    cdproj = 'SPS'
		ELSE
		    cdproj = 'MER'
		END IF
		iret   = 0
	    ELSE IF  ( ier .eq. -3 )  THEN
		iret   = -3
	    ELSE IF  ( ( ier .eq. -4 ) .and.
     +          ( LEN_TRIM(loc) .eq. 3 ) ) THEN
C
C*              Construct 4-char ICAO and check again
C
                loc = 'K' // loc
                CALL LC_FSTN  ( 'sfstns.tbl', loc, cenlat, cenlon, ier )
                IF  ( ier .eq. 0 )  THEN
                    diflat = 4.0
                    diflon = 7.0
                    iartyp = 2
                    stn(1) = loc
                    IF ( cenlat .gt. 25. ) THEN
                        cdproj = 'NPS'
                    ELSE IF ( cenlat .lt. -25. ) THEN
                        cdproj = 'SPS'
                    ELSE
                        cdproj = 'MER'
                    END IF
                    iret   = 0
                ELSE IF  ( ier .eq. -3 )  THEN
                    iret   = -3
                ENDIF
	    ENDIF
	ENDIF
C
C*	If area has been found--compute bounds with zoom factors.
C
	IF  ( iartyp .gt. 0 )  THEN
	    IF  ( izoom .le. 0 )  THEN
		zoomul = 2 ** (-izoom)
	    ELSE
		zoomul = 1. / (2 ** izoom)
	    ENDIF
	    IF ( iartyp .eq. 1 ) THEN
		zmofst = (1. - zoomul) / 2.
		rlatll = tlatll + (tlatur - tlatll) * zmofst
		rlatur = tlatur - (tlatur - tlatll) * zmofst
		rlonll = tlonll + (tlonur - tlonll) * zmofst
		rlonur = tlonur - (tlonur - tlonll) * zmofst
	    ELSE
		rlatll = cenlat - zoomul * diflat
		rlatur = cenlat + zoomul * diflat
		rlonll = cenlon - zoomul * diflon
		rlonur = cenlon + zoomul * diflon
	    ENDIF
	ENDIF
C*
	RETURN
	END


text:
      PROGRAM xstoerm
C     driver for routine stoerm
      INTEGER NVAR
      REAL HTOT,X1
      PARAMETER(NVAR=4,X1=0.,HTOT=1.570796)
      INTEGER i
      REAL a1,a2,x,xf,y(NVAR),yout(NVAR),d2y(NVAR),d2y1,d2y2
      EXTERNAL derivs
      d2y1(x)=x+sin(x)
      d2y2(x)=x**2+cos(x)-2
      y(1)=0.
      y(2)=-1.
      y(3)=2.
      y(4)=0.
      call derivs(X1,y,d2y)
      xf=X1+HTOT
      a1=d2y1(xf)
      a2=d2y2(xf)
      write(*,'(1x,a/)') 'Stoermer''s Rule:'
      do 11 i=5,45,10
        call stoerm(y,d2y,NVAR,X1,HTOT,i,yout,derivs)
        write(*,'(1x,a,f6.4,a,f6.4,a,i2,a)') 'X = ',X1,
     *       ' to ',X1+HTOT,' in ',i,' steps'
        write(*,'(1x,t5,a,t20,a)') 'Integration','Answer'
        write(*,'(1x,2f12.6)') yout(1),a1
        write(*,'(1x,2f12.6)') yout(2),a2
11    continue
      END
      SUBROUTINE derivs(x,y,d2y)
      REAL x,y(*),d2y(*)
      d2y(1)=x-y(1)
      d2y(2)=x*x-y(2)
      END

ext: for

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Examples/xstoerm.for


  real :: r1, r2
  complex :: c1, c2
  integer :: i1, i2
!$omp atomic write
  c1 = 0
!$omp atomic write
  r2 = 0
!$omp atomic write
  i2 = 0
!$omp atomic read
  r1 = c1
!$omp atomic read
  c2 = r2
!$omp atomic read
  i1 = r2
!$omp atomic read
  c2 = i2
!$omp atomic write
  c1 = r1
!$omp atomic write
  r2 = c2
!$omp atomic write
  r2 = i1
!$omp atomic write
  i2 = c2
!$omp end atomic
!$omp atomic write
  c1 = 1 + 2 + r1
!$omp atomic write
  r2 = c2 + 2 + 3
!$omp atomic write
  r2 = 3 + 4 + i1
!$omp atomic write
  i2 = c2 + 4 + 5
!$omp atomic
  c1 = c1 * 2.
!$omp atomic update
  r2 = r2 / 4
!$omp end atomic
!$omp atomic update
  i2 = i2 + 8
!$omp atomic capture
  c1 = c1 * 2.
  r1 = c1
!$omp end atomic
!$omp atomic capture
  c2 = r2
  r2 = r2 / 4
!$omp end atomic
!$omp atomic capture
  i2 = i2 + 8
  c2 = i2
!$omp end atomic
end


text:
*DECK DSLVS
      SUBROUTINE DSLVS (WM, IWM, X, TEM)
C***BEGIN PROLOGUE  DSLVS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEBDF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SLVS-S, DSLVS-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   DSLVS solves the linear system in the iteration scheme for the
C   integrator package DDEBDF.
C
C***SEE ALSO  DDEBDF
C***ROUTINES CALLED  DGBSL, DGESL
C***COMMON BLOCKS    DDEBD1
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920422  Changed DIMENSION statement.  (WRB)
C***END PROLOGUE  DSLVS
C
      INTEGER I, IER, IOWND, IOWNS, IWM, JSTART, KFLAG, L, MAXORD,
     1      MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST
      DOUBLE PRECISION DI, EL0, H, HL0, HMIN, HMXI, HU, PHL0,
     1      R, ROWND, ROWNS, TEM, TN, UROUND, WM, X
      DIMENSION WM(*), IWM(*), X(*), TEM(*)
      COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND,
     1                IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER,
     2                MAXORD,N,NQ,NST,NFE,NJE,NQU
C     ------------------------------------------------------------------
C      THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING
C      FROM A CHORD ITERATION.  IT IS CALLED BY DSTOD  IF MITER .NE. 0.
C      IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS.
C      IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL
C      MATRIX, AND THEN COMPUTES THE SOLUTION.
C      IF MITER IS 4 OR 5, IT CALLS DGBSL.
C      COMMUNICATION WITH DSLVS USES THE FOLLOWING VARIABLES..
C      WM  = DOUBLE PRECISION WORK SPACE CONTAINING THE INVERSE DIAGONAL
C      MATRIX IF MITER
C            IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE.
C            STORAGE OF MATRIX ELEMENTS STARTS AT WM(3).
C            WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA..
C            WM(1) = SQRT(UROUND) (NOT USED HERE),
C            WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER =
C            3.
C      IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING
C            AT IWM(21), IF MITER IS 1, 2, 4, OR 5.  IWM ALSO CONTAINS
C            THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS
C            4 OR 5.
C      X   = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION
C            VECTOR ON OUTPUT, OF LENGTH N.
C      TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION.
C      IER = OUTPUT FLAG (IN COMMON).  IER = 0 IF NO TROUBLE OCCURRED.
C            IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3.
C      THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N.
C-----------------------------------------------------------------------
C     BEGIN BLOCK PERMITTING ...EXITS TO 80
C        BEGIN BLOCK PERMITTING ...EXITS TO 60
C***FIRST EXECUTABLE STATEMENT  DSLVS
            IER = 0
            GO TO (10,10,20,70,70), MITER
   10       CONTINUE
            CALL DGESL(WM(3),N,N,IWM(21),X,0)
C     ......EXIT
            GO TO 80
C
   20       CONTINUE
            PHL0 = WM(2)
            HL0 = H*EL0
            WM(2) = HL0
            IF (HL0 .EQ. PHL0) GO TO 40
               R = HL0/PHL0
               DO 30 I = 1, N
                  DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2))
C        .........EXIT
                  IF (ABS(DI) .EQ. 0.0D0) GO TO 60
                  WM(I+2) = 1.0D0/DI
   30          CONTINUE
   40       CONTINUE
            DO 50 I = 1, N
               X(I) = WM(I+2)*X(I)
   50       CONTINUE
C     ......EXIT
            GO TO 80
   60    CONTINUE
         IER = -1
C     ...EXIT
         GO TO 80
C
   70    CONTINUE
         ML = IWM(1)
         MU = IWM(2)
         MEBAND = 2*ML + MU + 1
         CALL DGBSL(WM(3),MEBAND,N,ML,MU,IWM(21),X,0)
   80 CONTINUE
      RETURN
C     ----------------------- END OF SUBROUTINE DSLVS
C     -----------------------
      END


text:
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C $Id: eval_h_dummy.f,v 1.1 2002/05/02 18:52:16 andreasw Exp $

      subroutine EVAL_H(TASK, N, X, M, LAM, NNZH, HESS, IRNH, ICNH)

      implicit none
      integer TASK, N, M, NNZH
      double precision LAM(M), X(N), HESS(NNZH)
      integer IRNH(NNZH), ICNH(NNZH)

      write(*,*) 'Wrong choice of IPOPT parameters: Got into EVAL_H...'
      stop

      return
      end

max_stars_repo_name: kant/CMMPPT

max_issues_repo_name: kant/CMMPPT

max_forks_repo_name: kant/CMMPPT


text:
module a

integer, bind(c) :: global = 88
integer, dimension(2), bind(c) :: global_vec = [10, 20]
real :: global_not_bind = 1

contains

function add(x) bind(c) result(r)
	real :: x
	real :: r
	r =  x + 1
	global = x
	global_vec(2) = x
end function

function add_wo_bind(x)  result(r)
	real :: x
	real :: r
	r =  x + 1
end function

function tot(x, n) bind(c) result(r)
	integer :: n
	real, dimension(n) :: x
	real :: r
	r =  sum(x)
end function

subroutine mod(x) bind(c)
	real, dimension(3), intent(out) :: x
	x = 1
end subroutine

subroutine s(x, n) bind(c)
	character(1), dimension(3) :: x
	write(x, '(i0)') 9
end subroutine

subroutine s_wo_bind(x, n)
	character(30) :: x
	write(*, *) 9, x
end subroutine

subroutine svec(x) bind(c)
	character(1), dimension(4, 3) :: x
	character(3), dimension(4) :: y
	! transfer
	y(1)(1:1) = x(1, 1)
	y(1)(2:2) = x(2, 1)
	y(1)(3:3) = x(3, 1)

	!copy
	x(1, 3) = y(1)(1:1)
	x(2, 3) = y(1)(2:2)
	x(3, 3) = y(1)(3:3)

end subroutine

subroutine svec_wo_bind(x)
	character(3), dimension(4) :: x
	write(*, *) x(1), 1
	write(*, *) x(2), 2
	write(*, *) x(3), 3
	write(*, *) x(4), 4
end subroutine

subroutine err(x) bind(c)
	real x
	real y
	x = 10
	y = 1 / 0
end subroutine

end module

max_stars_repo_name: nicolasessisbreton/fython

max_issues_repo_name: nicolasessisbreton/fython

max_forks_repo_name: nicolasessisbreton/fython


text:
program command_line_arguments

  implicit none
  integer, parameter :: len_max = 256
  integer :: i , nargs
  character (len_max) :: arg

  nargs = command_argument_count()
  !nargs = iargc()
  do i = 0, nargs
    call get_command_argument (i, arg)
    !call getarg (i, arg)
    write (*, '(a)') trim (arg)
  end do

end program command_line_arguments

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
! This file is part of mctc-lib.
!
! 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.

module mctc_io_read_gaussian
   use mctc_env_accuracy, only : wp
   use mctc_env_error, only : error_type, fatal_error
   use mctc_io_structure, only : structure_type, new
   implicit none
   private

   public :: read_gaussian_external

contains

subroutine read_gaussian_external(self, unit, error)

   !> Instance of the molecular structure data
   type(structure_type), intent(out) :: self

   !> File handle
   integer, intent(in) :: unit

   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   integer :: stat, n, mode, chrg, spin, iat, ii
   integer, allocatable :: at(:)
   real(wp), allocatable :: xyz(:,:)
   real(wp) :: coord(3), q

   read(unit, '(4i10)', iostat=stat) n, mode, chrg, spin
   if (stat.ne.0) then
      call fatal_error(error, "Could not read number of atoms, check format!")
      return
   end if

   if (n <= 0) then
      call fatal_error(error, "Found no atoms, cannot work without atoms!")
      return
   end if

   allocate(xyz(3, n))
   allocate(at(n))

   ii = 0
   do while (ii < n)
      read(unit, '(i10, 4f20.12)', iostat=stat) iat, coord, q
      if (is_iostat_end(stat)) exit
      if (stat.ne.0) then
         call fatal_error(error, "Could not read geometry from Gaussian file")
         return
      end if
      if (iat > 0) then
         ii = ii+1
         at(ii) = iat
         xyz(:, ii) = coord
      else
         call fatal_error(error, "Invalid atomic number")
         return
      end if
   end do

   call new(self, at, xyz, charge=real(chrg, wp), uhf=spin)

   if (ii /= n) then
      call fatal_error(error, "Atom number missmatch in Gaussian file")
      return
   end if

end subroutine read_gaussian_external

end module mctc_io_read_gaussian

max_stars_repo_name: loriab/mctc-lib

max_issues_repo_name: loriab/mctc-lib

max_forks_repo_name: loriab/mctc-lib


text:
subroutine err_c_2_f_4 (i, j, k, n) bind(c)
  implicit none
  integer :: i,j,k,n
end subroutine err_c_2_f_4

subroutine err_c_value_f_pointer (x) bind(c)
  use iso_c_binding
  implicit none
  real(c_double) :: x
end subroutine err_c_value_f_pointer

subroutine err_c_float_f_double (ifab, lo, hi, x) bind(c)
  integer, intent(in) :: lo(3), hi(3)
  integer, intent(inout) :: ifab(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3))
  double precision, intent(out) :: x
end subroutine err_c_float_f_double

subroutine pass_c_real_f_real (x, y, z) bind(c)
  use iso_c_binding
  real(c_float), value :: x
  double precision, value :: y
  real(c_double), value :: z
end subroutine pass_c_real_f_real

module x_module

  use iso_c_binding
  use amrex_fort_module, only : amrex_real

  implicit none

  type, bind(c) :: my_c_struct
     double precision :: x(3)
     integer :: i(100)
  end type my_c_struct

contains

  function err_c_ret_int_f_ret_real () result(r)
    double precision :: r
  end function err_c_ret_int_f_ret_real

  function pass_c_ret_int_f_ret_int () result(r)
    integer :: r
  end function pass_c_ret_int_f_ret_int

  subroutine err_c_poiner_f_value (x) bind(c)
    use amrex_fort_module, only : amrex_real
    real(amrex_real), intent(in), value :: x
  end subroutine err_c_poiner_f_value

  subroutine err_c_reference_f_value (x) bind(c)
    use amrex_fort_module, only : amrex_real
    real(amrex_real), intent(in), value :: x
  end subroutine err_c_reference_f_value

  subroutine pass_c_bl_fort_fab_arg (x, xlo1, xlo2, xlo3, xhi1, xhi2, xhi3) bind(c)
    integer, intent(in) :: xlo1, xlo2, xlo3, xhi1, xhi2, xhi3
    real(amrex_real), intent(inout) :: x(xlo1:xhi1,xlo2:xhi2,xlo3:xhi3)
  end subroutine pass_c_bl_fort_fab_arg

  subroutine pass_c_bl_fort_fab_arg_3d (x, lo, hi) bind(c)
    integer, intent(in) :: lo(3), hi(3)
    real(amrex_real), intent(inout) :: x(lo(1):hi(1),lo(2):hi(2),lo(3):hi(3))
  end subroutine pass_c_bl_fort_fab_arg_3d

  subroutine pass_c_pointer_f_c_ptr (p) bind(c)
    use iso_c_binding
    type(c_ptr), value :: p
  end subroutine pass_c_pointer_f_c_ptr

  subroutine err_c_pointer_f_c_ptr (p) bind(c)
    use iso_c_binding
    type(c_ptr) :: p
  end subroutine err_c_pointer_f_c_ptr

  subroutine pass_c_void_pointer_f_any (x, y ,z) bind(c)
    integer :: x
    double precision :: y
    type(my_c_struct) :: z
  end subroutine pass_c_void_pointer_f_any

end module x_module

max_stars_repo_name: ylunalin/amrex

max_issues_repo_name: ylunalin/amrex

max_forks_repo_name: ylunalin/amrex


text:
As the largest rail company in the United States with over 50,000 miles of track that it controls, it may not be surprising that the train tracks that cross through Davis are owned by Union Pacific Railroad. Many different trains use the rails, notably Amtrak, but the rails themselves are the property of Union Pacific, or UP.

In 2010 there was a resurgence of the periodic concern over Pedestrian Train Track Safety rail safety with the announcement that UP plans to build a fence along the south side of the track near the depot with no pedestrian crossing. This fence, dubbed the Olive Drive Railroad Fence, caused a good deal of concern among some people residents. Union Pacific has a policy that for every new atgrade crossing they allow to be built, two must be removed.  Does anyone know why they have that policy?  What is their justification for it? http://www.uprr.com/reus/roadxing/industry/process/new_conversion.shtml They think atgrade crossings are inherently unsafe and would rather be rid of them all.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! TYPE  : MODULE
! NAME  : SpecialFunctions
! OBJECT: TYPE(func)
! USED  : CodeObject
! DATE  : 2018-03-27
! AUTHOR: hengyueli@gmail.com
!--------------
! Open-Source : No
!------------------
! DESCRIPTION:
!              ==========================
!               Special Funtionals-
!              ==========================
!              -------------------------
!              Legendre Polynomials :
!              p(n,x)
!              p(0,x) = 1
!              p(1,x) = x
!              k * p(k,x) = (2k-1) * x * p(k-1,x) - (k-1) * p(k-2,x) (k>=1)
!
! STANDARD:
!
!
! USING LIST:
!            :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
!
! avalable sets:
!                  []
!
!
! avalable gets:
!
!
!
!                 --------------
!                  [fun] GetLegendreP(n,x)
!                        integer::n
!                        real*8 ::x
!                        get the value of Legendre function
!
!                  [fun] GetLegendreDxP(n,x)
!                        derivative of GetLegendreP
!
!
!                  [fun] GetZerosOfLegendre(n,i)
!                        for P(n,x), it contains n zeros. Return the i-th zero (ascending order)
! avalable Is:
!
! others:
!
!
!
!
!
!
!
!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

module SpecialFunctions
  use CodeObject
  implicit none

  type,extends(object)::func
    !
  contains
    procedure,pass::GetLegendreP
    procedure,pass::GetLegendreDxP
    procedure,pass::GetZerosOfLegendre
  endtype

  private::GetLegendreP,GetLegendreDxP

contains

  real*8 function GetLegendreP(self,n,x)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n
    real*8,intent(in)::x
    !-------------------------------
    integer::jc
    REAL*8::pk_1,pk_2
    if (n.lt.0)then
      write(self%getprint(),*)"MathError: n<0 is not defined in GetLegendreP";stop
    elseif(n==0)then
      GetLegendreP = 1._8
    elseif(n==1)then
      GetLegendreP = x
    else
      pk_1 = x
      pk_2 = 1._8
      do jc = 2 , n
         GetLegendreP = (  (2*jc-1) * x * pk_1 - (jc-1) * pk_2 ) / jc
         pk_2 = pk_1
         pk_1 = GetLegendreP
      enddo
    endif
  endfunction

  real*8 function GetLegendreDxP(self,n,x)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n
    real*8,intent(in)::x
    !-------------------------------
    if (n.lt.0)then
      write(self%getprint(),*)"MathError: n<0 is not defined in GetLegendreP.";stop
    elseif(n==0)then
      GetLegendreDxP = 0._8
    else
      GetLegendreDxP = n * ( x *GetLegendreP(self,n,x) - GetLegendreP(self,n-1,x) )/(x**2.0_8-1._8)
    endif
  endfunction

  function GetZerosOfLegendre(self,n,i) result(r)
    implicit none
    class(func),intent(in)::self
    integer,intent(in)::n,i
    real*8::r
    !-------------------------------
    real*8,parameter::pi=3.14159265358979323846264338327950288439_8
    real*8::Pre,temp1

    Pre   = 0.000000000000001_8
    temp1 = 800.0_8  ! random large number

    if (n.lt.1)then
      write(self%getprint(),*)"MathError: For n<1 case, there is no zero for Legendre function.";stop
    else
      if ( (i.gt.0) .and. (i.le.n) )then
        !r = DCOS( (4*I-1)*pi/(4*N+2) )
        r = -DCOS( (4*I-1)*pi/(4*N+2) )   ! re-order
        do while ( abs( r - temp1) .gt.Pre )
           temp1 = r
           r     = r - GetLegendreP(self,n,temp1)/GetLegendreDxP(self,n,temp1)
        enddo
      else
        write(self%getprint(),*)"MathError: i should in range of [1,n] for GetZerosOfLegendre"
        write(self%getprint(),*)"However,now (i,n)=(",i,",",n,")";stop
      endif
    endif
  endfunction

endmodule

max_stars_repo_name: HengyueLi/SpecialFunctions

max_issues_repo_name: HengyueLi/SpecialFunctions

max_forks_repo_name: HengyueLi/SpecialFunctions


PROGRAM  question4
    IMPLICIT NONE

    INTEGER:: i, n
    REAL, DIMENSION(:), ALLOCATABLE:: x
    REAL:: sum = 0.0, mean, variance

    WRITE(*, *) "Enter dimention of the array"
    READ(*, *) n
    ALLOCATE(x(n))
    WRITE(*, 10) n
    10 FORMAT(/,"Enter ", i0, " real number for this array")
    READ(*, *) (x(i), i = 1, n)

    DO i = 1, n
        sum = sum + x(i)
    ENDDO

    mean = sum/n
    sum = 0.0
    DO i = 1, n
        sum = sum + (x(i) - mean)**2
    ENDDO
    variance = sum/(n-1)

    WRITE(*, 11) mean, variance
    11 FORMAT(/,"mean of data = ", f0.3/, "variance of the data = ", f0.3/)

END


text:
c     Subroutine to count good data
c     AJ_Kettle, 29Jun2019
c     18Mar2019: used for USAF updaate

      SUBROUTINE find_number_good(i_input,
     +   l_rgh_datalines,l_data,l_c1,
     +   i_vec_triplet_index,s_vec_windspeed_ms,
     +   ii_good,ii_bad)

      IMPLICIT NONE
c************************************************************************
c     Declare variables

      INTEGER             :: i_input
      INTEGER             :: l_rgh_datalines
      INTEGER             :: l_data
      INTEGER             :: l_c1
      INTEGER             :: i_vec_triplet_index(l_rgh_datalines)
      CHARACTER(LEN=l_c1) :: s_vec_windspeed_ms(l_rgh_datalines)
      INTEGER             :: ii_good,ii_bad
c*****
      INTEGER             :: i,j,k,ii,jj,kk
c************************************************************************

       ii_good=0
       ii_bad =0

c      Cycle through data column
       DO j=1,l_data
c       match triplet identifier
        IF (i_input.EQ.i_vec_triplet_index(j)) THEN
         IF (LEN_TRIM(s_vec_windspeed_ms(j)).GT.0) THEN

c          f_val_max=MAX(f_val_max,s_vec_windspeed_ms(j))
c          f_val_min=MIN(f_val_min,s_vec_windspeed_ms(j))

          ii_good=ii_good+1
         ENDIF
         IF (LEN_TRIM(s_vec_windspeed_ms(j)).EQ.0) THEN
          ii_bad=ii_bad+1
         ENDIF

        ENDIF
       ENDDO

c       print*,'i...',i,ii_good,ii_bad

      RETURN
      END

max_stars_repo_name: glamod/glamod-nuim

max_issues_repo_name: glamod/glamod-nuim

max_forks_repo_name: glamod/glamod-nuim


text:
!
! This file is part of LIBPFASST.
!
!>  User defined routines that can be called from inside libpfasst using hooks
module hooks
  use encap
  use pf_my_sweeper
  use probin
  implicit none

  interface
     function HypreMaxErr(x, t, init_cond) result(max_err) bind(c, name="HypreMaxErr")
        use iso_c_binding
        type(c_ptr), value :: x
        real(c_double), value :: t
        real(c_double), value :: init_cond
        real(c_double) :: max_err
     end function
  end interface
contains

  !>  Output the error and residual in the solution
  subroutine echo_error(pf, level_index)
    type(pf_pfasst_t), intent(inout) :: pf
    integer, intent(in) :: level_index

    real(pfdp) :: yexact
    real(pfdp) :: maxerr, error
    real(pfdp) :: residual
    class(hypre_vector_encap), pointer :: y_end
    integer :: nproc, rank, ierr

    !> Get the solution at the end of this step
    y_end => cast_as_hypre_vector(pf%levels(level_index)%qend)

    !>  compute error
    error = HypreMaxErr(y_end%c_hypre_vector_ptr, Tfin, init_cond)
    residual = pf%levels(level_index)%residual

    if (solver_type .eq. 1) then
       pf%results%residuals(level_index,1,pf%state%iter+1,1) = residual
       pf%results%errors(level_index,1,pf%state%iter+1,1) = error
    else
       pf%results%residuals(level_index,pf%state%pfblock,pf%state%iter+1,pf%state%sweep) = residual
       pf%results%errors(level_index,pf%state%pfblock,pf%state%iter+1,pf%state%sweep) = error
    end if

    !call mpi_comm_rank(pf%comm%comm, rank, ierr)
    !call mpi_comm_size(pf%comm%comm, nproc, ierr)

    if ((pf%rank == pf%comm%nproc-1) .and. (level_index == pf%nlevels) .and. (pf%state%iter .gt. 0) &
        .and. ((pf%state%step .eq. pf%state%nsteps-1) .or. (solver_type .eq. 1) .or. (solver_type .eq. 2))) then
       print '("error: rank: ", i4.4," step: ",i4.4," iter: ",i4.3," level: ",i2.2," error: ",es14.7," res: ",es18.10e4)', &
            pf%rank,pf%state%step+1, pf%state%iter,level_index, error, residual
       call flush(6)
    end if
  end subroutine echo_error

end module hooks

max_stars_repo_name: schreiberx/LibPFASST

max_issues_repo_name: schreiberx/LibPFASST

max_forks_repo_name: schreiberx/LibPFASST


text:
       subroutine getNLsign(iatom,ntype,is_ref,ip_ref,id_ref)
******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

       use fft_data
       use load_data
       use data

       implicit double precision (a-h,o-z)

       include 'param.escan_real'
       integer iatom(matom),iiatom(mtype),icore(mtype),numref(matom)
       integer ityatom(matom)
       integer is_ref(mtype),ip_ref(mtype),id_ref(mtype)
       real*8 occ_t(mtype)
       integer isNL(3,mtype),isNLa(9,matom),ipsp_type(mtype)
       real*8 Dij0(32,32,mtype),Qij(32,32,mtype)

       common /comisNL/isNL
       common /comisNLa/isNLa,Dij0,Qij,ipsp_all,ipsp_type
       common /comNL2/occ_t,iiatom,icore,numref,ityatom
***********************************************

       do ia=1,natom
	do itype=1,ntype
	if(iatom(ia).eq.iiatom(itype)) then
        kk=0
        if(is_ref(itype).eq.1) then
	isNLa(kk+1,ia)=isNL(1,itype)
        kk=kk+1
        endif
        if(ip_ref(itype).eq.1) then
	isNLa(kk+1,ia)=isNL(2,itype)
        isNLa(kk+2,ia)=isNL(2,itype)
        isNLa(kk+3,ia)=isNL(2,itype)
        kk=kk+3
        endif
        if(id_ref(itype).eq.1) then
        isNLa(kk+1,ia)=isNL(3,itype)
	isNLa(kk+2,ia)=isNL(3,itype)
        isNLa(kk+3,ia)=isNL(3,itype)
        isNLa(kk+4,ia)=isNL(3,itype)
        isNLa(kk+5,ia)=isNL(3,itype)
        kk=kk+5
        endif
	goto 11
	endif
	enddo
	write(6,*) "itype not found, stop", iatom(ia),ia
11      continue
      enddo

      return
      end

max_stars_repo_name: qsnake/petot

max_issues_repo_name: qsnake/petot

max_forks_repo_name: qsnake/petot


text:
! Copyright 2019 NREL

! 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.

MODULE Constants
    USE, INTRINSIC  :: ISO_C_Binding

    Character(*), PARAMETER     :: rosco_version = 'v2.5.0'             ! ROSCO version
    INTEGER, PARAMETER                  :: DbKi             = C_DOUBLE            !< Default kind for double floating-point numbers
    INTEGER, PARAMETER                  :: ReKi             = C_FLOAT             !< Default kind for single floating-point numbers
    INTEGER, PARAMETER                  :: IntKi            = C_INT               !< Default kind for integer numbers

    REAL(DbKi), PARAMETER               :: RPS2RPM          = 9.5492966           ! Factor to convert radians per second to revolutions per minute.
    REAL(DbKi), PARAMETER               :: R2D              = 57.295780           ! Factor to convert radians to degrees.
    REAL(DbKi), PARAMETER               :: D2R              = 0.0175              ! Factor to convert degrees to radians.
    REAL(DbKi), PARAMETER               :: PI               = 3.14159265359       ! Mathematical constant pi
    INTEGER(IntKi), PARAMETER           :: NP_1             = 1                   ! First rotational harmonic
    INTEGER(IntKi), PARAMETER           :: NP_2             = 2                   ! Second rotational harmonic

    ! NWTC Constants
    INTEGER(IntKi), PARAMETER     :: NWTC_MAX_DLL_PROC    = 3
    INTEGER(IntKi), PARAMETER     :: ErrID_None   = 0                              !< ErrStat parameter indicating "no error"
    INTEGER(IntKi), PARAMETER     :: ErrID_Info   = 1                              !< ErrStat parameter indicating "informational message"
    INTEGER(IntKi), PARAMETER     :: ErrID_Warn   = 2                              !< ErrStat parameter indicating "warning"
    INTEGER(IntKi), PARAMETER     :: ErrID_Severe = 3                              !< ErrStat parameter indicating "severe error";
    INTEGER(IntKi), PARAMETER     :: ErrID_Fatal  = 4                              !< ErrStat parameter indicating "fatal error"; simulation should end
    INTEGER, PARAMETER            :: BITS_IN_ADDR  = C_INTPTR_T*8                  !< The number of bits in an address (32-bit or 64-bit).

END MODULE Constants

max_stars_repo_name: ptrbortolotti/ROSCO

max_issues_repo_name: ptrbortolotti/ROSCO

max_forks_repo_name: mvanv/ROSCO


module GraphClass
    use VertexClass
    use IOClass
    use MathClass
    use RandomClass
    implicit none

    type :: Graph_
        ! Group of G(V, E),
        ! where V is vertex, E is edge

        ! adjacency matrix
        integer(int32),allocatable :: AdjacencyMatrix(:,:)

        ! vertex info
        type(Vertex_),allocatable :: Vertex(:)

        ! global info
        integer(int32),allocatable :: Global_ID(:)

        integer(int32) :: NumOfVertex=0

    contains
        procedure, public :: add => addGraph ! add vertex or edge
        procedure, public :: update => updateGraph ! update vertex or edge
        procedure, public :: show => showGraph
        procedure, public :: remove => removeGraph
        procedure, public :: sync => syncGraph
    end type
contains

! ######################################
subroutine removeGraph(obj,onlyVertex)
    class(Graph_),intent(inout) :: obj
    logical,optional,intent(in) :: onlyVertex

    deallocate(obj%vertex)

    if(present(onlyVertex) )then
        if(onlyVertex.eqv. .true.)then
            return
        endif
    endif

    deallocate(obj%AdjacencyMatrix)
    obj%NumOfVertex=0

end subroutine
! ######################################

! ######################################
subroutine addGraph(obj,vertex,from, to,between,and)
    class(Graph_),intent(inout) :: obj
    type(Vertex_),optional,intent(inout) :: vertex
    type(Vertex_),allocatable :: vlist(:)
    integer(int32),optional,intent(in) :: from, to,between,and
    integer(int32) :: i

    if(present(vertex) )then
        obj%NumOfVertex=obj%NumOfVertex+1
        vertex%ID = obj%NumOfVertex
    endif

    if(present(vertex) )then
        if(.not. allocated(obj%Vertex) )then
            allocate(obj%Vertex(1))
            obj%Vertex(1) = vertex%copy()
            if(allocated(obj%AdjacencyMatrix) ) deallocate(obj%AdjacencyMatrix)
            allocate(obj%AdjacencyMatrix(1,1) )
            obj%AdjacencyMatrix(1,1)=0
        else
            allocate(vlist(size(obj%Vertex) ) )
            do i=1,size(obj%Vertex,1 )
                vlist(i) = obj%Vertex(i)%copy()
            enddo
            deallocate(obj%Vertex)
            allocate(obj%Vertex(size(vlist,1)+1 )  )
            do i=1,size(vlist,1)
                obj%Vertex(i) = vlist(i)%copy()
            enddo
            obj%Vertex( size(vlist,1) + 1 ) = vertex%copy()
            call extend(mat=obj%AdjacencyMatrix,extend1stColumn=.true.,DefaultValue=0)
            call extend(mat=obj%AdjacencyMatrix,extend2ndColumn=.true.,DefaultValue=0)
        endif
    endif

    if(present(from) .and. present(to) )then
        obj%AdjacencyMatrix(from, to) =  1
        obj%AdjacencyMatrix(to, from) = -1
    endif

    if(present(between) .and. present(and) )then
        obj%AdjacencyMatrix(between, and) =  1
        obj%AdjacencyMatrix(and, between) =  1
    endif

end subroutine
! ######################################

! ######################################
subroutine updateGraph(obj,ID,vertex,from, to,between,and)
    class(Graph_),intent(inout) :: obj
    type(Vertex_),optional,intent(inout) :: vertex
    type(Vertex_),allocatable :: vlist(:)
    integer(int32),intent(in) :: ID
    integer(int32),optional,intent(in) :: from, to, between,and
    integer(int32) :: i

    if(ID > size(obj%vertex) )then
        print *, "ERROR :: updateGraph >> please add vertex before update."
        stop
    else
        obj%Vertex(ID) = vertex%copy()
    endif

    if(present(from) .and. present(to) )then
        obj%AdjacencyMatrix(from, to) =  1
        obj%AdjacencyMatrix(to, from) = -1
    endif

    if(present(between) .and. present(and) )then
        obj%AdjacencyMatrix(between, and) =  1
        obj%AdjacencyMatrix(and, between) =  1
    endif

end subroutine
! ######################################

! ######################################
subroutine showGraph(obj,withname)
    class(Graph_),intent(in) :: obj
    logical,optional,intent(in)::withname
    type(IO_) :: f
    character(200) :: command

    integer(int32) :: id,n,i,j

    n=size(obj%vertex)
    call f%open("./","vertex",".txt")
    do i=1,n
        call f%write(str(obj%vertex(i)%x)//" "//str(obj%vertex(i)%y)//" "//str(obj%vertex(i)%z)  )
    enddo
    call f%close()

    call f%open("./","showGraph",".gp")

    if(present(withname) )then
        if(withname .eqv. .False.)then
            do i=1,n
                command = "set label 'vertex:"//trim(str(i))//"' at "//str(obj%vertex(i)%x)//","//str(obj%vertex(i)%y)
                call f%write(trim(command) )
            enddo
        else
            do i=1,n
                command = "set label 'ID:"//trim(str(i))//" Name: "//trim(obj%vertex(i)%name)&
                //"' at "//str(obj%vertex(i)%x)//","//str(obj%vertex(i)%y)
                call f%write(trim(command) )
            enddo
        endif
    else
        do i=1,n
            command = "set label 'ID:"//trim(str(i))//" Name: "//trim(obj%vertex(i)%name)&
            //"' at "//str(obj%vertex(i)%x)//","//str(obj%vertex(i)%y)
            call f%write(trim(command) )
        enddo
    endif

    id=0
    do i=1,n
        do j=1,n
            if(obj%AdjacencyMatrix (i,j) > 0)then
                id=id+1
                command = "set arrow "//trim(str(id))//" head filled from "&
                //str(obj%vertex(i)%x)//","//str(obj%vertex(i)%y)//" to "&
                //str(obj%vertex(j)%x)//","//str(obj%vertex(j)%y)
                call f%write(trim(command) )

            elseif(obj%AdjacencyMatrix (i,j) < 0)then
                id=id+1
                command = "set arrow "//trim(str(id))//" head filled from "&
                //str(obj%vertex(j)%x)//","//str(obj%vertex(j)%y)//" to "&
                //str(obj%vertex(i)%x)//","//str(obj%vertex(i)%y)
                call f%write(trim(command) )
            else
                cycle
            endif
        enddo
    enddo
    call f%write("unset key")
    call f%write("plot './vertex.txt'")
    call f%write("pause -1")
    call f%close()

    call system("gnuplot ./showGraph.gp")
end subroutine
! ######################################

! ######################################
subroutine syncGraph(obj,AdjacencyMatrix)
    class(Graph_),intent(inout) :: obj
    integer(int32),intent(in)::AdjacencyMatrix(:,:)
    integer(int32) :: i,j,buf(2)

    do i=1,size(AdjacencyMatrix,1)
        do j=1,size(AdjacencyMatrix,2)
            if(AdjacencyMatrix(i,j) == 0)then
                cycle
            endif

            if(AdjacencyMatrix(i,j)*obj%AdjacencyMatrix(i,j) < 0 )then
                obj%AdjacencyMatrix(i,j) = 1
                obj%AdjacencyMatrix(j,i) = 1
            endif
            if(AdjacencyMatrix(i,j)*obj%AdjacencyMatrix(i,j) > 0 )then
                cycle
            endif
            if(AdjacencyMatrix(i,j)*obj%AdjacencyMatrix(i,j) == 0 )then
                obj%AdjacencyMatrix(i,j) = obj%AdjacencyMatrix(i,j) + AdjacencyMatrix(i,j)
            endif

        enddo
    enddo

end subroutine
! ######################################

end module GraphClass


text:
module buffer_mod

use mpi_f08, only: MPI_Win
use mpi_f08, only: MPI_Comm
use mpi_f08, only: MPI_ADDRESS_KIND
use iso_c_binding, only: c_ptr

type :: buffer_shared_t

    logical                         :: active = .false.

    integer(kind=MPI_ADDRESS_KIND)  :: size !! in bytes
    integer(kind=8)                 :: elem_size
    integer(kind=8)                 :: elem_count

    integer                         :: mpirank
    type(MPI_Comm)                  :: mpicomm
    type(MPI_Win)                   :: window
    type(c_ptr)                     :: baseptr

    integer                         :: disp_unit

end type

type :: buffer_serial_t

    logical                         :: active = .false.

    integer(kind=8)                 :: size !! in bytes
    integer(kind=8)                 :: elem_size
    integer(kind=8)                 :: elem_count

    character(len=1), allocatable   :: buffer(:)
    type(c_ptr)                     :: baseptr

end type

interface buffer_allocate
    procedure :: buffer_serial_allocate
    procedure :: buffer_shared_allocate
end interface

interface buffer_free
    procedure :: buffer_serial_free
    procedure :: buffer_shared_free
end interface

interface buffer_move
    procedure :: buffer_serial_move
    procedure :: buffer_shared_move
end interface

contains

subroutine buffer_serial_allocate(elem_size,elem_count,handle)

    use iso_c_binding, only: c_loc

    integer(kind=8), intent(in)         :: elem_size !! in bytes
    integer(kind=8), intent(in)         :: elem_count
    type(buffer_serial_t), target, intent(out)  :: handle

    handle%elem_size = elem_size
    handle%elem_count = elem_count
    handle%size = elem_size * elem_count

    allocate(handle%buffer(handle%size))

    handle%baseptr = c_loc(handle%buffer)

    handle%active = .true.

end subroutine

subroutine buffer_serial_free(handle)

    use iso_c_binding, only: c_null_ptr

    type(buffer_serial_t), intent(inout)   :: handle

    if (allocated(handle%buffer)) then
        handle%active = .false.
        deallocate(handle%buffer)
        handle%baseptr = c_null_ptr

        handle%elem_size = 0
        handle%elem_count = 0
        handle%size = 0

    end if

end subroutine

subroutine buffer_serial_move(src,snk)

    use iso_c_binding, only: c_null_ptr, c_loc

    type(buffer_serial_t), target, intent(inout) :: src,snk

    snk%active = .true.
    snk%elem_size = src%elem_size
    snk%elem_count = src%elem_count
    snk%size = src%size

    call move_alloc(src%buffer,snk%buffer)
    snk%baseptr = c_loc(snk%buffer)

    !! -- !!

    src%active = .false.
    src%baseptr = c_null_ptr
    src%elem_size = 0
    src%elem_count = 0
    src%size = 0

end subroutine

subroutine buffer_shared_allocate(elem_size,elem_count,comm,handle)

    use MPI_f08, only: MPI_Comm
    use mpi_f08, only: MPI_Comm_rank
    use mpi_f08, only: MPI_INFO_NULL
    use mpi_f08, only: MPI_Address_Kind
    use mpi_f08, only: MPI_Win_allocate_shared

    integer(kind=8), intent(in)                 :: elem_size !! in bytes
    integer(kind=8), intent(in)                 :: elem_count !! in bytes
    type(MPI_Comm), intent(in)                  :: comm
    type(buffer_shared_t), intent(out)          :: handle

    integer :: ierror

    call MPI_Comm_rank(comm,handle%mpirank,ierror)

    handle%elem_size    = elem_size
    handle%elem_count   = elem_count
    handle%mpicomm      = comm

    if (handle%mpirank == 0) then
        handle%size = elem_size * elem_count
        call MPI_Win_allocate_shared(handle%size, 1, MPI_INFO_NULL, comm, handle%baseptr, handle%window, ierror)
    else
        handle%size = 0
        call MPI_Win_allocate_shared(handle%size, 1, MPI_INFO_NULL, comm, handle%baseptr, handle%window, ierror)
        call MPI_Win_shared_query(handle%window, 0, handle%size, handle%disp_unit, handle%baseptr, ierror)
    end if

    handle%active = .true.

end subroutine

subroutine buffer_shared_free(handle)

    use iso_c_binding, only: c_null_ptr

    type(buffer_shared_t), intent(inout) :: handle

    integer :: ierror, assert

    if (handle%active) then
        handle%active = .false.
        call MPI_Win_free(handle%window, ierror)
        handle%baseptr = c_null_ptr

        handle%elem_size = 0
        handle%elem_count = 0
        handle%size = 0
    end if

end subroutine

subroutine buffer_shared_move(src,snk)

    use iso_c_binding, only: c_null_ptr
    use mpi_f08, only: MPI_COMM_NULL, MPI_WIN_NULL

    type(buffer_shared_t), intent(inout) :: src,snk

    snk = src

    src%active = .false.
    src%window = MPI_WIN_NULL
    src%mpicomm = MPI_COMM_NULL
    src%baseptr = c_null_ptr
    src%disp_unit = -1

    src%elem_size = 0
    src%elem_count = 0
    src%size = 0

end subroutine

end module

max_stars_repo_name: jmark/nemo

max_issues_repo_name: jmark/nemo

max_forks_repo_name: jmark/nemo


text:
      subroutine initialize(mx,my,meqn,mbc,
     &      xlower,ylower,dx,dy,q,curvature,area)
     &      bind(c,name="initialize")
      implicit none

      integer meqn, mbc, mx, my, blockno
      double precision xlower, ylower, dx, dy, dxdy
      integer*8 cont
      double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)
      integer i, j

      include 'fclaw2d_metric_terms.i'

      dxdy = dx*dy
      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            q(i,j,1) = area(i,j)/dxdy
            q(i,j,2) = curvature(i,j)
         enddo
      enddo

      return
      end

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
program test_allgatherv
  use libmpifx_module
  implicit none

  type(mpifx_comm) :: mycomm
  integer, parameter :: sp = kind(1.0)
  real(sp), allocatable :: send1(:), send2(:,:)
  real(sp), allocatable :: recv1(:), recv2(:,:)
  real(sp) :: send0
  integer, allocatable :: recvcounts(:)
  integer, allocatable :: displs(:)
  integer :: ii, nrecv, nCol
  character(100) :: formstr
  character(*), parameter :: label = "(I2.2,'-',I3.3,'|',1X"

  call mpifx_init()
  call mycomm%init()

  ! R1 -> R1
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *) 'Test gather rank=1 -> rank=1'
  end if
  allocate(send1(mycomm%rank+1))
  send1 = real(mycomm%rank+1, sp)
  ! recv1 size is 1+2+3+...+mycomm%size
  nrecv = mycomm%size*(mycomm%size+1)/2
  allocate(recv1(nrecv))
  allocate(recvcounts(mycomm%size))
  do ii = 1, mycomm%size
    recvcounts(ii) = ii
  end do
  call mpifx_allgatherv(mycomm, send1, recv1, recvcounts)
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *) "Recv1 buffer:", recv1
  end if
  deallocate(recvcounts)
  deallocate(recv1)

  ! R2 -> R2
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *)
    write(*, *) 'Test gather rank=2 -> rank=2'
  end if
  nCol = 5
  allocate(send2(nCol, mycomm%rank+1))
  send2 = real(mycomm%rank + 1, sp)
  ! recv1 size is 1+2+3+...+mycomm%size
  nrecv = mycomm%size*(mycomm%size+1)/2
  allocate(recv2(nCol, nrecv))
  recv2 = 0
  allocate(recvcounts(mycomm%size))
  do ii = 1, mycomm%size
    recvcounts(ii) = nCol*ii
  end do
  call mpifx_allgatherv(mycomm, send2, recv2, recvcounts)
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *) "Recv2 buffer:", shape(recv2)
    do ii = 1, nrecv
      write(*,*)recv2(:,ii)
    end do
  end if
  deallocate(recvcounts)

  ! R0 -> R1 with specified receive pattern
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *)
    write(*, *) 'Test gather scalar -> rank=1'
  end if
  send0 = real(mycomm%rank + 1, sp)
  nrecv = mycomm%size
  allocate(recv1(nrecv))
  allocate(recvcounts(mycomm%size))
  recvcounts = 1
  allocate(displs(mycomm%size))
  ! set a non trivial displs vector
  do ii = 1, mycomm%size
    displs(ii) = mycomm%size - ii
  end do
  call mpifx_allgatherv(mycomm, send0, recv1, recvcounts, displs)
  if (mycomm%rank == mycomm%size - 1) then
    write(*, *) "Recv1 buffer:", recv1
  end if

  call mpifx_finalize()

end program test_allgatherv

max_stars_repo_name: terminationshock/mpifx

max_issues_repo_name: terminationshock/mpifx

max_forks_repo_name: terminationshock/mpifx


text:
C      MODULE POSTPROC
C      CONTAINS

      SUBROUTINE ESCVTK(NMNE,NUMNP,NUMPARA,NEQ,NDOFDIM,JJJ,COORD,
     1                  IELCON,IELT,ID,NUMEL,UTMAST)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION ID(NDOFDIM,NUMNP),COORD(NDOFDIM,NUMNP),
     1          IELCON(NMNE,NUMEL),UTMAST(NEQ)
      DIMENSION IELT(NUMEL)

      IF (NMNE==4) THEN
        CALL VTK_4NODES(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ,
     1                  COORD,IELCON(:,1:NUMPARA),ID,UTMAST)
      END IF

      IF (NMNE==8 .AND. NDOFDIM==2) THEN
        CALL VTK_8NODES(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ,
     1                  COORD,IELCON(:,1:NUMPARA),ID,UTMAST)
      END IF

      IF (NMNE==8 .AND. NDOFDIM==3) THEN
        CALL VTK_8NODES3D(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ,
     1                  COORD,IELCON(:,1:NUMPARA),ID,UTMAST)
      END IF

	  IMIN=MINVAL(IELT(1:NUMPARA))
	  IMAX=MAXVAL(IELT(1:NUMPARA))

	  IF (IMIN==3 .AND. IMAX==6) THEN
C23456789012345678901234567890123456789012345678901234567890123456789012
	  	CALL VTK_6_9NODES(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ, COORD,
     1                  IELCON(:,1:NUMPARA),IELT(1:NUMPARA),ID,UTMAST)
C  	CALL VTK_6_9NODES(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ, COORD,
C 1                    IELCON(:,1:NUMPARA), IELT(1:NUMPARA),
C 2                    ID, UTMAST)
	  ELSE
     	IF (NMNE==9) THEN
        	CALL VTK_9NODES(NUMNP, NUMPARA, NEQ, NDOFDIM, JJJ,
     1                      COORD,IELCON(:,1:NUMPARA),ID,UTMAST)
      	END IF

      END IF

      RETURN

      END SUBROUTINE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C              PROGRAMA PARA GENERAR ARCHIVOS PARA PARAVIEW                   C
C                      PARA ELEMENTOS DE 4 NODOS                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VTK_4NODES(NP, NELE, NEQ, NDOFDIM, NTIEMPO, COORD,
     1                      MIE, ID, UTMASDT)
C
      IMPLICIT NONE
C
      CHARACTER (25) :: NOMBRE
      CHARACTER (13) :: NPOLY
C
      CHARACTER (4) :: EXTENSION=".vtk"
      CHARACTER (5) :: B
      CHARACTER (28) :: AA="# vtk DataFile Version 4.3.1"
      CHARACTER (59) :: CC
      CHARACTER (5) :: DD ="ASCII"
      CHARACTER (16) :: EE ="DATASET POLYDATA"
      CHARACTER (7) :: FF ="POINTS "
      CHARACTER (16) :: GG ="TRIANGLE_STRIPS "
      CHARACTER (50) :: HH
      CHARACTER (16) :: II
      CHARACTER (16) :: JJ
C
      CHARACTER (11) :: LL ="POINT_DATA "
      CHARACTER (30) :: MM ="SCALARS desplazamientoz double"
      CHARACTER (20) :: NN ="LOOKUP_TABLE default"
C
C
      INTEGER I, J, K, L, W, KK
C
      INTEGER, INTENT(IN):: NP
      INTEGER, INTENT(IN):: NELE
      INTEGER, INTENT(IN):: NEQ
      INTEGER, INTENT(IN):: NDOFDIM
      INTEGER, INTENT(IN):: NTIEMPO
C
      REAL*8 MAGNITUD
C
      INTEGER, DIMENSION(4,NELE), INTENT(IN):: MIE
      CHARACTER*3 IMP
      REAL*8 juan
      REAL*8 DESPX, DESPY
      REAL*8, DIMENSION(NDOFDIM, NP), INTENT(IN):: COORD
      INTEGER, DIMENSION(NDOFDIM, NP), INTENT(IN):: ID
      REAL*8, DIMENSION(NEQ), INTENT(IN):: UTMASDT

      REAL*8, DIMENSION(NP, 2):: UT
C
C
      UT=0.0D0
C
      K=1
C
      DO I=1, NP
        DO J=1, 2
            IF (ID(J,I)>0) THEN
                UT(I,J)=UTMASDT(K)
                K=K+1
            END IF
        END DO
      END DO
C
      CC="this is a test file with scalar field defined at the points"
C
C   LEE LOS DATOS GENERALES DEL PROBLEMA
C
      NPOLY="vtk/Body_T"
C
      WRITE(B,'(I0)') NTIEMPO
C
      NOMBRE=TRIM(NPOLY)//TRIM(B)//TRIM(EXTENSION)
      OPEN(70,FILE=NOMBRE)
C
C     INICIA A LLENAR EL ARCHIVO
C
C     ESCRIBE LAS 1AS LINES DEL FORMATO VTK
C
      WRITE(70,'(A)') AA
      WRITE(70,'(A, /A)') CC
      WRITE(70,'(A)') DD
      WRITE(70,'(A)') EE
      WRITE(II,'(I0)') NP
C
      HH=FF//II//" DOUBLE"
C
      WRITE(70,'(A, /A)') HH
C
C
      DO J=1, NP
C
        DESPX=UT(J,1)
        DESPY=UT(J,2)
C
C    WRITE(70,'(3F10.6)') COORD(1, J)+DESPX/10.0D0, COORD(2, J)+DESPY/10.0D0, 0.0D0
        WRITE(70,'(3F11.6)') COORD(1, J), COORD(2, J), 0.0D0
C
      END DO
C
C
      WRITE(70,'(A)') ""
      WRITE(II,'(I0)') NELE
      WRITE(JJ,'(I0)') NELE*5
      HH=GG//TRIM(II)//" "//JJ
      WRITE(70,'(A)')TRIM(HH)
C
C
      DO J=1, NELE
C
        WRITE(70,'(1I2, 4I8)') 4, MIE(3,J)-1, MIE(4,J)-1,
     1                             MIE(2,J)-1, MIE(1, J)-1
C
      END DO
C
C
      WRITE(70,'(A)')""
      WRITE(II,'(I0)') NP
      HH=LL//TRIM(II)
      WRITE(70,'(A)') TRIM(HH)
      WRITE(70,'(A)') MM
      WRITE(70,'(A)') NN
C
C
      DO J=1, NP
C
        DESPX=DSQRT(UT(J,1)**2+UT(J,2)**2)

        WRITE(70,'(1F11.6)') DESPX
C
      END DO
C
C
      CLOSE(70)
C
      RETURN
C
C
      END SUBROUTINE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C              PROGRAMA PARA GENERAR ARCHIVOS PARA PARAVIEW                   C
C                      PARA ELEMENTOS DE 8 NODOS                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VTK_8NODES(NP, NELE, NEQ, NDOFDIM, NTIEMPO, COORD,
     1                      MIE, ID, UTMASDT)
C
      IMPLICIT NONE
C
      CHARACTER (25) :: NOMBRE
      CHARACTER (13) :: NPOLY
C
      CHARACTER (4) :: EXTENSION=".vtk"
      CHARACTER (5) :: B

      INTEGER I, J, K, L, W, KK
C
      INTEGER, INTENT(IN):: NP
      INTEGER, INTENT(IN):: NELE
      INTEGER, INTENT(IN):: NEQ
      INTEGER, INTENT(IN):: NDOFDIM
      INTEGER, INTENT(IN):: NTIEMPO
C
      REAL*8 MAGNITUD
C
      INTEGER, DIMENSION(8,NELE), INTENT(IN):: MIE
      CHARACTER*3 IMP
      REAL*8 juan
      REAL*8 DESPX, DESPY
      REAL*8, DIMENSION(NDOFDIM, NP), INTENT(IN):: COORD
      INTEGER, DIMENSION(NDOFDIM, NP), INTENT(IN):: ID
      REAL*8, DIMENSION(NEQ), INTENT(IN):: UTMASDT

      REAL*8, DIMENSION(NP, 2):: UT
C
C
      UT=0.0D0
C
      K=1
C
      DO I=1, NP
        DO J=1, 2
            IF (ID(J,I)>0) THEN
                UT(I,J)=UTMASDT(K)
                K=K+1
            END IF
        END DO
      END DO
C
C   LEE LOS DATOS GENERALES DEL PROBLEMA
C
      NPOLY="vtk/Body_T"
C
      WRITE(B,'(I0)') NTIEMPO
C
      NOMBRE=TRIM(NPOLY)//TRIM(B)//TRIM(EXTENSION)
      OPEN(70,FILE=NOMBRE)

      WRITE(70,'(A28)') "# vtk DataFile Version 4.3.1"
      WRITE(70,*) ""
      WRITE(70,'(A5)') "ASCII"
      WRITE(70,'(A25)') "DATASET UNSTRUCTURED_GRID"
      WRITE(70,*) "POINTS",NP,"float"
      WRITE(70,*) ""

      DO J=1, NP

        DESPX=UT(J,1)
        DESPY=UT(J,2)

c        WRITE(70,'(3F10.6)') COORD(1, J)+DESPX/10.0D0,
c     1                       COORD(2, J)+DESPY/10.0D0, 0.0D0
        WRITE(70,'(3F11.6)') COORD(1, J), COORD(2, J), 0.0D0

      END DO

      WRITE(70,*) ""

      WRITE(70,*) "CELLS", NELE, NELE*9

      DO I=1,NELE
        WRITE(70,'(1I3,8I8)') 8, MIE(:,I)-1
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "CELL_TYPES",NELE
      DO I=1,NELE
        WRITE(70,'(I2.2)') 23
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "POINT_DATA",NP
cc      WRITE(70,'(A7,A6,A6)') "VECTORS","DESPL","float"

      WRITE(70,*) "SCALARS displacement double"
      WRITE(70,*) "LOOKUP_TABLE default"

cc      DO I=1,NP
cc        WRITE(70,'(3F12.8)') UT(I,1)/10.0D0, UT(I,2)/10.0D0, 0.0
cc      END DO

      DO J=1, NP
C
        DESPX=DSQRT(UT(J,1)**2+UT(J,2)**2)

        WRITE(70,'(1F11.6)') DESPX
C
      END DO

      CLOSE(70)

      RETURN
C
C
      END SUBROUTINE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C              PROGRAMA PARA GENERAR ARCHIVOS PARA PARAVIEW                   C
C                      PARA ELEMENTOS DE 8 NODOS                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VTK_9NODES(NP, NELE, NEQ, NDOFDIM, NTIEMPO, COORD,
     1                      MIE, ID, UTMASDT)
C
      IMPLICIT NONE
C
      CHARACTER (25) :: NOMBRE
      CHARACTER (13) :: NPOLY
C
      CHARACTER (4) :: EXTENSION=".vtk"
      CHARACTER (5) :: B

      INTEGER I, J, K, L, W, KK
C
      INTEGER, INTENT(IN):: NP
      INTEGER, INTENT(IN):: NELE
      INTEGER, INTENT(IN):: NEQ
      INTEGER, INTENT(IN):: NDOFDIM
      INTEGER, INTENT(IN):: NTIEMPO
C
      REAL*8 MAGNITUD
C
      INTEGER, DIMENSION(9,NELE), INTENT(IN):: MIE
      CHARACTER*3 IMP
      REAL*8 juan
      REAL*8 DESPX, DESPY
      REAL*8, DIMENSION(NDOFDIM, NP), INTENT(IN):: COORD
      INTEGER, DIMENSION(NDOFDIM, NP), INTENT(IN):: ID
      REAL*8, DIMENSION(NEQ), INTENT(IN):: UTMASDT

      REAL*8, DIMENSION(NP, 2):: UT
C
C
      UT=0.0D0
C
      K=1
C
      DO I=1, NP
        DO J=1, 2
            IF (ID(J,I)>0) THEN
                UT(I,J)=UTMASDT(K)
                K=K+1
            END IF
        END DO
      END DO
C
C   LEE LOS DATOS GENERALES DEL PROBLEMA
C
      NPOLY="vtk/Body_T"
C
      WRITE(B,'(I0)') NTIEMPO
C
      NOMBRE=TRIM(NPOLY)//TRIM(B)//TRIM(EXTENSION)
      OPEN(70,FILE=NOMBRE)

      WRITE(70,'(A28)') "# vtk DataFile Version 4.3.1"
      WRITE(70,*) ""
      WRITE(70,'(A5)') "ASCII"
      WRITE(70,'(A25)') "DATASET UNSTRUCTURED_GRID"
      WRITE(70,*) "POINTS",NP,"float"
      WRITE(70,*) ""

      DO J=1, NP

        DESPX=UT(J,1)
        DESPY=UT(J,2)

c        WRITE(70,'(3F10.6)') COORD(1, J)+DESPX/10.0D0,
c     1                       COORD(2, J)+DESPY/10.0D0, 0.0D0
        WRITE(70,'(3F11.6)') COORD(1, J), COORD(2, J), 0.0D0

      END DO

      WRITE(70,*) ""

      WRITE(70,*) "CELLS", NELE, NELE*10

      DO I=1,NELE
        WRITE(70,'(1I3,9I8)') 9, MIE(:,I)-1
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "CELL_TYPES",NELE
      DO I=1,NELE
        WRITE(70,'(I2.2)') 28
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "POINT_DATA",NP
cc      WRITE(70,'(A7,A6,A6)') "VECTORS","DESPL","float"

      WRITE(70,*) "SCALARS displacement double"
      WRITE(70,*) "LOOKUP_TABLE default"

cc      DO I=1,NP
cc        WRITE(70,'(3F12.8)') UT(I,1)/10.0D0, UT(I,2)/10.0D0, 0.0
cc      END DO

      DO J=1, NP
C
        DESPX=DSQRT(UT(J,1)**2+UT(J,2)**2)

        WRITE(70,'(1F11.6)') DESPX
C
      END DO

      CLOSE(70)

      RETURN
C
C
      END SUBROUTINE

C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C              PROGRAMA PARA GENERAR ARCHIVOS PARA PARAVIEW                   C
C                      PARA ELEMENTOS DE 8 NODOS                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VTK_8NODES3D(NP, NELE, NEQ, NDOFDIM, NTIEMPO, COORD,
     1                      MIE, ID, UTMASDT)
C
      IMPLICIT NONE
C
      CHARACTER (25) :: NOMBRE
      CHARACTER (13) :: NPOLY
C
      CHARACTER (4) :: EXTENSION=".vtk"
      CHARACTER (5) :: B

      INTEGER I, J, K, L, W, KK
C
      INTEGER, INTENT(IN):: NP
      INTEGER, INTENT(IN):: NELE
      INTEGER, INTENT(IN):: NEQ
      INTEGER, INTENT(IN):: NDOFDIM
      INTEGER, INTENT(IN):: NTIEMPO
C
      REAL*8 MAGNITUD
C
      INTEGER, DIMENSION(8,NELE), INTENT(IN):: MIE
      CHARACTER*3 IMP
      REAL*8 juan
      REAL*8 DESPX, DESPY, DESPZ
      REAL*8, DIMENSION(NDOFDIM, NP), INTENT(IN):: COORD
      INTEGER, DIMENSION(NDOFDIM, NP), INTENT(IN):: ID
      REAL*8, DIMENSION(NEQ), INTENT(IN):: UTMASDT

      REAL*8, DIMENSION(NP, 3):: UT
C
C
      UT=0.0D0
C
      K=1
C
      DO I=1, NP
        DO J=1, 3
            IF (ID(J,I)>0) THEN
                UT(I,J)=UTMASDT(K)
                K=K+1
            END IF
        END DO
      END DO
C
C   LEE LOS DATOS GENERALES DEL PROBLEMA
C
      NPOLY="vtk/Body_T"
C
      WRITE(B,'(I0)') NTIEMPO
C
      NOMBRE=TRIM(NPOLY)//TRIM(B)//TRIM(EXTENSION)
      OPEN(70,FILE=NOMBRE)

      WRITE(70,'(A28)') "# vtk DataFile Version 4.3.1"
      WRITE(70,*) ""
      WRITE(70,'(A5)') "ASCII"
      WRITE(70,'(A25)') "DATASET UNSTRUCTURED_GRID"
      WRITE(70,*) "POINTS",NP,"float"
      WRITE(70,*) ""

      DO J=1, NP

        DESPX=UT(J,1)
        DESPY=UT(J,2)
        DESPZ=UT(J,3)

c        WRITE(70,'(3F10.6)') COORD(1, J)+DESPX/10.0D0,
c     1                       COORD(2, J)+DESPY/10.0D0, 0.0D0
        WRITE(70,'(3F11.6)') COORD(1, J), COORD(2, J), COORD(3, J)

      END DO

      WRITE(70,*) ""

      WRITE(70,*) "CELLS", NELE, NELE*9

      DO I=1,NELE
        WRITE(70,'(1I3,9I8)') 8, MIE(:,I)-1
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "CELL_TYPES",NELE
      DO I=1,NELE
        WRITE(70,'(I2.2)') 12
      END DO
      WRITE(70,*) ""

      WRITE(70,*) "POINT_DATA",NP
cc      WRITE(70,'(A7,A6,A6)') "VECTORS","DESPL","float"

      WRITE(70,*) "SCALARS displacement double"
      WRITE(70,*) "LOOKUP_TABLE default"

cc      DO I=1,NP
cc        WRITE(70,'(3F12.8)') UT(I,1)/10.0D0, UT(I,2)/10.0D0, 0.0
cc      END DO

      DO J=1, NP
C
        DESPX=DSQRT(UT(J,1)**2+UT(J,2)**2+UT(J,3)**2)

        WRITE(70,'(1F11.6)') DESPX
C
      END DO

      CLOSE(70)

      RETURN
C
C
      END SUBROUTINE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C              PROGRAMA PARA GENERAR ARCHIVOS PARA PARAVIEW                   C
C                      PARA ELEMENTOS DE 9 Y 6 NODOS                          C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE VTK_6_9NODES(NP, NELE, NEQ, NDOFDIM, NTIEMPO, COORD,
     1                      MIE, ELETYPE, ID, UTMASDT)
C
      IMPLICIT NONE
C
      CHARACTER (25) :: NOMBRE
      CHARACTER (13) :: NPOLY
C
      CHARACTER (4) :: EXTENSION=".vtk"
      CHARACTER (5) :: B

      INTEGER I, J, K, L, W, KK
      INTEGER NTR, NREC
C
      INTEGER, INTENT(IN):: NP
      INTEGER, INTENT(IN):: NELE
      INTEGER, INTENT(IN):: NEQ
      INTEGER, INTENT(IN):: NDOFDIM
      INTEGER, INTENT(IN):: NTIEMPO
C
      REAL*8 MAGNITUD
C
      INTEGER, DIMENSION(9,NELE), INTENT(IN):: MIE
      INTEGER, DIMENSION(NELE), INTENT(IN):: ELETYPE
      CHARACTER*3 IMP
      REAL*8 juan
      REAL*8 DESPX, DESPY
      REAL*8, DIMENSION(NDOFDIM, NP), INTENT(IN):: COORD
      REAL*8, DIMENSION(NEQ), INTENT(IN):: UTMASDT
      INTEGER, DIMENSION(NDOFDIM, NP), INTENT(IN):: ID

      REAL*8, DIMENSION(NP, 2):: UT

	  NTR=0
	  NREC=0

	  DO I=1, NELE
	  	IF(ELETYPE(I)==6) THEN
	  		NTR=NTR+1
	  	ELSE
	  		NREC=NREC+1
	  	END IF
	  END DO

      UT=0.0D0

      K=1

      DO I=1, NP
        DO J=1, 2
            UT(I,J)=UTMASDT(K)
            K=K+1
        END DO
      END DO

C   LEE LOS DATOS GENERALES DEL PROBLEMA

      NPOLY="vtk/Body_T"

      WRITE(B,'(I0)') NTIEMPO

      NOMBRE=TRIM(NPOLY)//TRIM(B)//TRIM(EXTENSION)
      OPEN(70,FILE=NOMBRE)

      WRITE(70,'(A28)') "# vtk DataFile Version 4.3.1"
      WRITE(70,*) ""
      WRITE(70,'(A5)') "ASCII"
      WRITE(70,'(A25)') "DATASET UNSTRUCTURED_GRID"
      WRITE(70,*) "POINTS",NP,"float"
      WRITE(70,*) ""

      DO J=1, NP

        DESPX=UT(J,1)
        DESPY=UT(J,2)

c        WRITE(70,'(3F10.6)') COORD(1, J)+DESPX/10.0D0,
c     1                       COORD(2, J)+DESPY/10.0D0, 0.0D0
        WRITE(70,'(3F12.8)') COORD(1, J), COORD(2, J), 0.0D0

      END DO

      WRITE(70,*) ""

      WRITE(70,*) "CELLS", NELE, NTR*7+NREC*10	!NELE*10

	  J=0
      DO I=1,NTR
      	J=J+1
        WRITE(70,'(1I2,6I7)') 6, MIE(1:6,I)-1
      END DO

      DO I=1,NREC
      	J=J+1
        WRITE(70,'(1I2,9I7)') 9, MIE(:,J)-1
      END DO

      WRITE(70,*) ""

      WRITE(70,*) "CELL_TYPES", NELE

      DO I=1,NTR
        WRITE(70,'(I2.2)') 22
      END DO

      DO I=1,NREC
        WRITE(70,'(I2.2)') 28
      END DO

      WRITE(70,*) ""

      WRITE(70,*) "POINT_DATA",NP
cc      WRITE(70,'(A7,A6,A6)') "VECTORS","DESPL","float"

      WRITE(70,*) "SCALARS displacement double"
      WRITE(70,*) "LOOKUP_TABLE default"

cc      DO I=1,NP
cc        WRITE(70,'(3F12.8)') UT(I,1)/10.0D0, UT(I,2)/10.0D0, 0.0
cc      END DO

      DO J=1, NP
C
        DESPX=DSQRT(UT(J,1)**2+UT(J,2)**2)

        WRITE(70,'(1F10.6)') DESPX
C
      END DO

      CLOSE(70)

      RETURN

      END SUBROUTINE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE IMPISTOUT3D(NIMP,ISTOUT,NEQ,NDOFDIM,NUMNP,ID,
     1						 UTMINT,UT,UTMAST,IDISP,IVEL,IACEL,DT)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION ID(NDOFDIM,NUMNP),ISTOUT(NIMP),UTMAST(NEQ),
     1			UTMINT(NEQ), UT(NEQ)

      UX=0.0D0
      UY=0.0D0
      UZ=0.0D0

	  UVELX=0.0D0
	  UVELY=0.0D0
	  UVELZ=0.0D0

	  UACELX=0.0D0
	  UACELY=0.0D0
	  UACELZ=0.0D0

      DO I=1, NIMP
        J=ISTOUT(I)
        II=ID(1,J)
        JJ=ID(2,J)
        KK=ID(3,J)

        IF (II.NE.0) THEN
            UX=UTMAST(II)
            UVELX= 1.0D0/(2.0D0*DT)*(-UTMINT(II)+UTMAST(II))
            UACELX=1.0D0/(DT**2)*(UTMINT(II)-2.0D0*UT(II)+UTMAST(II))
        END IF

        IF (JJ.NE.0) THEN
            UY=UTMAST(JJ)
            UVELY= 1.0D0/(2.0D0*DT)*(-UTMINT(JJ)+UTMAST(JJ))
            UACELY=1.0D0/(DT**2)*(UTMINT(JJ)-2.0D0*UT(JJ)+UTMAST(JJ))
        END IF

        IF (KK.NE.0) THEN
            UZ=UTMAST(KK)
            UVELZ= 1.0D0/(2.0D0*DT)*(-UTMINT(KK)+UTMAST(KK))
            UACELZ=1.0D0/(DT**2)*(UTMINT(KK)-2.0D0*UT(KK)+UTMAST(KK))
        END IF

        WRITE(IDISP,'(3F12.6)') UX, UY, UZ
        WRITE(IVEL,'(3F12.6)') UVELX, UVELY, UVELZ
        WRITE(IACEL,'(3F12.6)') UACELX, UACELY, UACELZ

      UX=0.0D0
      UY=0.0D0
      UZ=0.0D0

	  UVELX=0.0D0
	  UVELY=0.0D0
	  UVELZ=0.0D0

	  UACELX=0.0D0
	  UACELY=0.0D0
	  UACELZ=0.0D0

      END DO

      RETURN

      END SUBROUTINE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE IMPISTOUT2D(NIMP,ISTOUT,NEQ,NDOFDIM,NUMNP,ID,
     1						 UTMINT,UT,UTMAST,IDISP,IVEL,IACEL,DT)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION ID(NDOFDIM,NUMNP),ISTOUT(NIMP),UTMAST(NEQ),
     1			UTMINT(NEQ), UT(NEQ)

C     OJO QUE ACÁ ESTÁ AMARRADO A 2 GRADOS DE LIBERTAD POR NODO

      UX=0.0D0
      UY=0.0D0

	  UVELX=0.0D0
	  UVELY=0.0D0

	  UACELX=0.0D0
	  UACELY=0.0D0

      DO I=1, NIMP
        J=ISTOUT(I)
        II=ID(1,J)
        JJ=ID(2,J)

        IF (II.NE.0) THEN
            UX=UTMAST(II)
            UVELX= 1.0D0/(2.0D0*DT)*(-UTMINT(II)+UTMAST(II))
            UACELX=1.0D0/(DT**2)*(UTMINT(II)-2.0D0*UT(II)+UTMAST(II))
        END IF

        IF (JJ.NE.0) THEN
            UY=UTMAST(JJ)
            UVELY= 1.0D0/(2.0D0*DT)*(-UTMINT(JJ)+UTMAST(JJ))
            UACELY=1.0D0/(DT**2)*(UTMINT(JJ)-2.0D0*UT(JJ)+UTMAST(JJ))
        END IF

        WRITE(IDISP,'(2F12.6)') UX, UY
        WRITE(IVEL,'(2F12.6)') UVELX, UVELY
        WRITE(IACEL,'(2F12.6)') UACELX, UACELY

        UX=0.0D0
        UY=0.0D0

	  	UVELX=0.0D0
        UVELY=0.0D0

	  	UACELX=0.0D0
        UACELY=0.0D0

      END DO

      RETURN

      END SUBROUTINE

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	  SUBROUTINE ELAPSED(T3, KINC)

	  IMPLICIT REAL*8(A-H,O-Z)

	  REAL*8  ELAPSED_TIME
      INTEGER T3, T4, CLOCK_RATE, KINC
      REAL*8 SEC, MINU, HOR
      INTEGER MINUI, HORI

	  CALL SYSTEM_CLOCK(T4, CLOCK_RATE)

      ELAPSED_TIME = FLOAT(T4 - T3) / FLOAT(CLOCK_RATE)

	  HOR=  ELAPSED_TIME/3600.0D0
	  HORI= INT(HOR)
	  MINU= (HOR-HORI)*60.0D0
	  MINUI= INT(MINU)
	  SEC=  (MINU-MINUI)*60.D0

      WRITE(*,'(1A12,1I16,1A16,1I5,1A7,1I3,1A8,1F6.2,1A9)')
     1								'Increment: ', KINC,
     2 								'Elapsed time: ',
     3                              HORI, 'hours',
     4								MINUI, 'minutes',
     5								SEC, 'seconds'

	  RETURN

	  END SUBROUTINE

c        END MODULE POSTPROC


text:
! PR middle-end/43337
! { dg-do compile }
! { dg-options "-fopenmp -O2 -g" }

subroutine pr43337
  integer :: a, b(10)
  call foo (b)
  call bar (b)
contains
  subroutine foo (b)
    integer :: b(10)
!$omp parallel if (.false.)
!$omp task if (.false.) shared(b)
    do a = 1, 10
      b(a) = 1
    end do
!$omp end task
!$omp end parallel
  end subroutine foo
  subroutine bar (b)
    integer :: b(10)
!$omp parallel if (.false.)
!$omp parallel if (.false.)
    do a = 1, 10
      b(a) = 1
    end do
!$omp end parallel
!$omp end parallel
  end subroutine bar
end subroutine pr43337

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
module BEMT_Test

   use BEMT

   contains

function Test_inductionfactors_1()

end function Test_inductionfactors_1

end module BEMT_Test

max_stars_repo_name: old-NWTC/AeroDyn

max_issues_repo_name: old-NWTC/AeroDyn

max_forks_repo_name: old-NWTC/AeroDyn


text:
      MODULE STAT_POOL
      IMPLICIT NONE

      CHARACTER                        :: DUMP*500, DUMP2*15
      CHARACTER                        :: DUMP3*1
      CHARACTER(LEN=30), ALLOCATABLE   :: STATIONNAMES (:)
      CHARACTER(LEN=30), ALLOCATABLE   :: STATIONNAMES_O (:)
      CHARACTER(LEN=15), ALLOCATABLE   :: DATUM_SP     (:)
      CHARACTER(LEN=15), ALLOCATABLE   :: DATUM_O      (:,:)
      CHARACTER(LEN=15), ALLOCATABLE   :: FMT_O        (:)
      CHARACTER(LEN=15), ALLOCATABLE   :: FMT_O_F      (:)
      CHARACTER(LEN=3)                 :: CHTMP
      CHARACTER(LEN=4)                 :: YYYY         !YYYY MM DD hh
      CHARACTER(LEN=2)                 :: MM, DD, hh, MINUTE, SEC ! MIN(x,y) is a fortran function
      CHARACTER(LEN=30)                :: FMT_ERG_HEADER
      CHARACTER(LEN=30)                :: FMT_NAM_HEADER
      CHARACTER(LEN=30)                :: FMT_ERG_RESULT
      CHARACTER(LEN=30)                :: FMT_ERG_ALL_STAT
      CHARACTER(LEN=30),  ALLOCATABLE  :: BNAMES(:)
      CHARACTER(LEN=2)                 :: TMPCHAR

      REAL*8, PARAMETER                :: SMALL = 0.0000000001d0

      LOGICAL                          :: FOUND

      INTEGER  , ALLOCATABLE           :: N_OBSRV_ERR(:), N_OUT_TIME(:), N_STAT(:)

      INTEGER                          :: MSC_O_MAX = 47

      REAL*8                           :: PI, DUMP_R
      INTEGER                          :: N_DT_O_MAX, DUMP_I
      INTEGER, ALLOCATABLE             :: N_DT_O (:)
      INTEGER, ALLOCATABLE             :: MSC_O(:), N_DT_ERR(:,:)

      INTEGER                          :: DATAEND, DUMP_INT, COUNTER
      INTEGER                          :: BUOYS, BUOYS_O, N_DT_SP, ERG, MSC, MDC, ISEMAX

      REAL*8                             :: M0, M1, M2, INCR_DT, INTER_DT, INTER, PI2, DDIR
      REAL*8                             :: TMP1, TMP2, TMP3, TMP4, CUT_OFF, DUMMY, DX, DIFF_DX
      REAL*8                             :: DT, DIFF_DT, YINTER, MINMAXFREQ_O, FRINTF, SGHIG, SGLOW

      REAL*8, ALLOCATABLE                :: FREQ_SP  (:)  , DFREQ_SP(:)
      REAL*8, ALLOCATABLE                :: SPSIG(:), SPDIR(:)
      REAL*8, ALLOCATABLE                :: E_SP     (:)  , NDIR  (:), DSPR  (:), COSTH(:), SINTH(:)
      REAL*8, ALLOCATABLE                :: EMAX_O(:,:), EMAX_SP(:,:)
      REAL*8, ALLOCATABLE                :: AUX_M0_SP(:)  , AUX_M1_SP(:), AUX_M2_SP(:), DS_INCR_SP(:)

      REAL*8, ALLOCATABLE                :: HS_SP (:,:), TM01_SP(:,:), TM02_SP(:,:), TP_SP(:,:), TP_O(:,:)
      REAL*8, ALLOCATABLE                :: HS_SP_CLEAN (:,:), TM01_SP_CLEAN(:,:), TM02_SP_CLEAN(:,:), TP_SP_CLEAN(:,:)

      REAL*8, ALLOCATABLE                :: DIFF_HS_SP(:,:), DIFF2_HS_SP(:,:), ABS_DIFF_HS_SP(:,:)
      REAL*8, ALLOCATABLE                :: DIFF_TM01_SP(:,:), DIFF2_TM01_SP(:,:), ABS_DIFF_TM01_SP(:,:)
      REAL*8, ALLOCATABLE                :: DIFF_TM02_SP(:,:), DIFF2_TM02_SP(:,:), ABS_DIFF_TM02_SP(:,:)
      REAL*8, ALLOCATABLE                :: DIFF_TP_SP(:,:), DIFF2_TP_SP(:,:), ABS_DIFF_TP_SP(:,:)

      REAL*8     , ALLOCATABLE           :: DIFF3_HS_SP(:,:), DIFF3_TM01_SP(:,:), DIFF3_TM02_SP(:,:), DIFF3_TP_SP(:,:)
      REAL*8     , ALLOCATABLE           :: DIFF4_HS_SP(:,:), DIFF4_TM01_SP(:,:), DIFF4_TM02_SP(:,:), DIFF4_TP_SP(:,:)

      REAL*8     , ALLOCATABLE           :: DIFF1_ESP(:,:), DIFF2_ESP(:,:), MEAN_OSP(:,:), MEAN_BSP(:,:), BIAS_SP(:,:)
      REAL*8     , ALLOCATABLE           :: DIFF1_K(:,:), DIFF2_K(:,:), DIFF3_K(:,:), DIFF4_K(:,:), KORR_SP(:,:)

      REAL*8     , ALLOCATABLE           :: MEAN_HS_O(:)  , BIAS_HS_SP(:)  , MAE_HS_SP(:)
      REAL*8     , ALLOCATABLE           :: RMS_HS_SP(:)  , SCI_HS_SP(:)   , MEAN_HS_SP (:)
      REAL*8     , ALLOCATABLE           :: MEAN_TM01_O(:), BIAS_TM01_SP(:), MAE_TM01_SP(:)
      REAL*8     , ALLOCATABLE           :: RMS_TM01_SP(:), SCI_TM01_SP(:) , MEAN_TM01_SP(:)
      REAL*8     , ALLOCATABLE           :: MEAN_TM02_O(:), BIAS_TM02_SP(:), MAE_TM02_SP(:)
      REAL*8     , ALLOCATABLE           :: RMS_TM02_SP(:), SCI_TM02_SP(:) , MEAN_TM02_SP(:)
      REAL*8     , ALLOCATABLE           :: MEAN_TP_O(:)  , BIAS_TP_SP(:)  , MAE_TP_SP(:)
      REAL*8     , ALLOCATABLE           :: RMS_TP_SP(:)  , SCI_TP_SP(:)   , MEAN_TP_SP (:)
      REAL*8     , ALLOCATABLE           :: KORR_HS(:), KORR_TM01(:), KORR_TM02(:), KORR_TP(:)

      REAL*8                             :: MEAN_O_HS_ALL  , MEAN_SP_HS_ALL
      REAL*8                             :: MEAN_O_TM01_ALL, MEAN_SP_TM01_ALL
      REAL*8                             :: MEAN_O_TM02_ALL, MEAN_SP_TM02_ALL
      REAL*8                             :: MEAN_O_TP_ALL  , MEAN_SP_TP_ALL
      REAL*8                             :: BIAS_HS_ALL
      REAL*8                             :: BIAS_TM01_ALL
      REAL*8                             :: BIAS_TM02_ALL
      REAL*8                             :: RMS_HS_ALL
      REAL*8                             :: RMS_TM01_ALL
      REAL*8                             :: RMS_TM02_ALL
      REAL*8                             :: MAE_HS_ALL
      REAL*8                             :: MAE_TM01_ALL
      REAL*8                             :: MAE_TM02_ALL
      REAL*8                             :: SCI_HS_ALL
      REAL*8                             :: SCI_TM01_ALL
      REAL*8                             :: SCI_TM02_ALL
      REAL*8                             :: KORR_HS_ALL
      REAL*8                             :: KORR_TM01_ALL
      REAL*8                             :: KORR_TM02_ALL
      REAL*8                             :: BIAS_TP_ALL
      REAL*8                             :: RMS_TP_ALL
      REAL*8                             :: MAE_TP_ALL
      REAL*8                             :: SCI_TP_ALL
      REAL*8                             :: KORR_TP_ALL

      LOGICAL, PARAMETER               :: LWRITEALL = .TRUE.

      REAL*8, ALLOCATABLE                ::  E_O (:), E_OS(:,:), E_B(:,:), NDIR_B(:,:), DSPR_B(:,:)
      REAL*8, ALLOCATABLE                ::  E_OSF(:,:), E_BT(:,:), RMS_B(:,:)
      REAL*8, ALLOCATABLE                ::  AUX_M0_O(:) , AUX_M1_O(:), AUX_M2_O(:)
      REAL*8, ALLOCATABLE                ::  HS_O (:,:), TM01_O(:,:), TM02_O(:,:)
      REAL*8, ALLOCATABLE                ::  HS_O_CLEAN (:,:), TM01_O_CLEAN(:,:), TM02_O_CLEAN(:,:)
      REAL*8, ALLOCATABLE                ::  TP_O_CLEAN (:,:)

      REAL*8, ALLOCATABLE                ::  FREQ_O(:,:), DFREQ_O(:,:)
      DOUBLE PRECISION, ALLOCATABLE    ::  ZEIT_SP(:)
      DOUBLE PRECISION, ALLOCATABLE    ::  ZEIT_O(:,:)
      DOUBLE PRECISION                 ::  XMJD

      END MODULE

max_stars_repo_name: rustychris/schism

max_issues_repo_name: rustychris/schism

max_forks_repo_name: rustychris/schism


text:
! RUN: bbc %s -o "-" -emit-fir | FileCheck %s

! CHECK-LABEL: func @_QPsub() {
subroutine sub()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QPasubroutine() {
subroutine AsUbRoUtInE()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QPfoo() -> f32 {
function foo()
  real(4) :: foo
  real :: pi = 3.14159
! CHECK: }
end function

! CHECK-LABEL: func @_QPfunctn() -> f32 {
function functn
  real, parameter :: pi = 3.14
! CHECK: }
end function

module testMod
contains
  ! CHECK-LABEL: func @_QMtestmodPsub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QMtestmodPfoo() -> f32 {
  function foo()
    real(4) :: foo
  ! CHECK: }
  end function
end module

! CHECK-LABEL: func @_QPfoo2()
function foo2()
  real(4) :: foo2
contains
  ! CHECK-LABEL: func @_QFfoo2Psub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QFfoo2Pfoo() {
  subroutine foo()
  ! CHECK: }
  end subroutine
end function

! CHECK-LABEL: func @_QPsub2()
subroutine sUb2()
contains
  ! CHECK-LABEL: func @_QFsub2Psub() {
  subroutine sub()
  ! CHECK: }
  end subroutine

  ! CHECK-LABEL: func @_QFsub2Pfoo() {
  subroutine Foo()
  ! CHECK: }
  end subroutine
end subroutine

module testMod2
contains
  ! CHECK-LABEL: func @_QMtestmod2Psub()
  subroutine sub()
  contains
    ! CHECK-LABEL: func @_QMtestmod2FsubPsubsub() {
    subroutine subSub()
    ! CHECK: }
    end subroutine
  end subroutine
end module

module color_points
  interface
    module subroutine draw()
    end subroutine
    module function erase()
      integer(4) :: erase
    end function
  end interface
end module color_points

! We don't handle lowering of submodules yet.  The following tests are
! commented out and "CHECK" is changed to "xHECK" to not trigger FileCheck.
!submodule (color_points) color_points_a
!contains
!  ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aPsub() {
!  subroutine sub
!  end subroutine
!  ! xHECK: }
!end submodule
!
!submodule (color_points:color_points_a) impl
!contains
!  ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplPfoo()
!  subroutine foo
!    contains
!    ! xHECK-LABEL: func @_QMcolor_pointsScolor_points_aSimplFfooPbar() {
!    subroutine bar
!    ! xHECK: }
!    end subroutine
!  end subroutine
!  ! xHECK-LABEL: func @_QMcolor_pointsPdraw() {
!  module subroutine draw()
!  end subroutine
!  !FIXME func @_QMcolor_pointsPerase() -> i32 {
!  module procedure erase
!  ! xHECK: }
!  end procedure
!end submodule

! CHECK-LABEL: func @_QPshould_not_collide() {
subroutine should_not_collide()
! CHECK: }
end subroutine

! CHECK-LABEL: func @_QQmain() {
program test
! CHECK: }
contains
! CHECK-LABEL: func @_QFPshould_not_collide() {
subroutine should_not_collide()
! CHECK: }
end subroutine
end program

! CHECK-LABEL: func @omp_get_num_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads"} {
function omp_get_num_threads() bind(c)
! CHECK: }
end function

! CHECK-LABEL: func @get_threads() -> f32 attributes {fir.sym_name = "_QPomp_get_num_threads_1"} {
function omp_get_num_threads_1() bind(c, name ="get_threads")
! CHECK: }
end function

! CHECK-LABEL: func @bEtA() -> f32 attributes {fir.sym_name = "_QPalpha"} {
function alpha() bind(c, name =" bEtA ")
! CHECK: }
end function

! CHECK-LABEL: fir.global internal @_QFfooEpi : f32 {

max_stars_repo_name: akashhansda/llvm-project

max_issues_repo_name: akashhansda/llvm-project

max_forks_repo_name: akashhansda/llvm-project


text:
program phaml_master
use phaml
implicit none
type(phaml_solution_type) :: soln
call phaml_create(soln)
call phaml_solve_pde(soln,max_refsolveloop=1,degree=3,task=REFINE_ONLY)
open(unit=21,file="savestiff.dat")
open(unit=22,file="saverhs.dat")
call phaml_store_matrix(soln,stiffness_unit=21,rhs_unit=22)
close(21)
close(22)
call phaml_destroy(soln,finalize_mpi=.false.)
call phaml_create(soln,eq_type=EIGENVALUE)
call phaml_solve_pde(soln,max_refsolveloop=1,degree=3,task=REFINE_ONLY)
open(unit=23,file="savemass.dat")
call phaml_store_matrix(soln,mass_unit=23)
close(23)
call phaml_destroy(soln)

end program phaml_master

max_stars_repo_name: qsnake/phaml

max_issues_repo_name: qsnake/phaml

max_forks_repo_name: qsnake/phaml


!***********************************/
!	Name:前処理のみで使う構造型の定義モジュール
!	Alias:StructVar_OnlyUsePreProcess
!	Description:凸包を作るときのみに用いる
!	Type:UnstructuredGrid
!	Input:UG%GM%Dimension,UG%xxx%Point,UG%GM%Width (xxxは使用する種類のセルデータ)
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.01.20
!	Update:-
!	Other:
!***********************************/
 module StructVar_OnlyUsePreProcess
implicit none
    type MakeConvexHull
        integer, allocatable :: OutlineCell(:) !0:InternalCell, 1:OutlineCell
    end type
 end module StructVar_OnlyUsePreProcess