text:
      subroutine openf (iread,fname)
      integer iread
      character *(*) fname
      if (iread .eq. 0) then
        open (2,file=fname,form='unformatted',status='new')
      else
        open (2,file=fname,form='unformatted',status='old')
      endif
      end
c
      subroutine closef
      close (2)
      end
c
      subroutine readif (icnt,idata,ierr)
      integer icnt,idata(*)
      read (2,end=10) (idata(i),i=1,icnt)
      ierr = 0
      return
   10 ierr = 1
      end
c
      subroutine readff (icnt,rdata,ierr)
      integer icnt
      real*4 rdata(*)
      read (2,end=10) (rdata(i),i=1,icnt)
      ierr = 0
      return
   10 ierr = 1
      end
c
      subroutine readdf (icnt,rdata,ierr)
      integer icnt
      real*8 rdata(*)
      read (2,end=10) (rdata(i),i=1,icnt)
      ierr = 0
      return
   10 ierr = 1
      end
c
      subroutine readgff (icnt,rdata,idata,ierr)
      integer icnt,idata(*),ierr
      real*4 rdata(*)
      read (2,end=10) (rdata(i),i=1,3*icnt),(idata(i),i=1,icnt)
      ierr = 0
      return
   10 ierr = 1
      end
c
      subroutine readgdf (icnt,rdata,idata,ierr)
      integer icnt,idata(*),ierr
      real*8 rdata(*)
      read (2,end=10) (rdata(i),i=1,3*icnt),(idata(i),i=1,icnt)
      ierr = 0
      return
   10 ierr = 1
      end
c
      subroutine writeif (icnt,idata,ierr)
      integer icnt,idata(*)
      write (2) (idata(i),i=1,icnt)
      ierr = 0
      end
c
      subroutine writeff (icnt,rdata,ierr)
      integer icnt
      real*4 rdata(*)
      write (2) (rdata(i),i=1,icnt)
      ierr = 0
      end
c
      subroutine writedf (icnt,rdata,ierr)
      integer icnt
      real*8 rdata(*)
      write (2) (rdata(i),i=1,icnt)
      ierr = 0
      end
c
      subroutine writegff (icnt,rdata,idata,ierr)
      integer icnt,idata(*),ierr
      real*4 rdata(*)
      write (2) (rdata(i),i=1,3*icnt),(idata(i),i=1,icnt)
      ierr = 0
      end
c
      subroutine writegdf (icnt,rdata,idata,ierr)
      integer icnt,idata(*),ierr
      real*8 rdata(*)
      write (2) (rdata(i),i=1,3*icnt),(idata(i),i=1,icnt)
      ierr = 0
      end

max_stars_repo_name: mfolusiak/CGNS

max_issues_repo_name: mfolusiak/CGNS

max_forks_repo_name: mfolusiak/CGNS


text:
      SUBROUTINE PZBSLANCZOS( N, STEPS, A, IA, JA, DESCA, B, IB, JB,
     $                        DESCB, X, IX, JX, DESCX, ALPHA, BETA, SCL,
     $                        INFO )
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            N, STEPS, IA, JA, IB, JB, IX, JX, INFO
      DOUBLE PRECISION   SCL
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( * ), B( * ), X( * )
      DOUBLE PRECISION   ALPHA( * ), BETA( * )
      INTEGER            DESCA( * ), DESCB( * ), DESCX( * )
*     ..
*
*  Purpose
*  =======
*
*  PZBSLANCZOS() computes the structure preserving Lanczos decomposition
*
*     H**2 * [ U; conj(U) ] = [ U; conj(U) ] * T + [rank 1],
*
*  where
*
*     H = [       A,        B;
*          -conj(B), -conj(A) ],
*
*  is the Behte--Salpeter Hamiltonian with
*
*     Omega = [      A,       B;
*              conj(B), conj(A) ]
*
*  positive definite, and [ U; conj(U) ] satisfies the orthogonal
*  property
*
*     [ U; conj(U) ]**H * [ V; conj(V) ] = 2 * I,
*
*  where
*
*     [ V; conj(V) ] = Omega * [ U; conj(U) ].
*
*  No argument check is performed, i.e.,
*  all arguments are assumed to be valid.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          2*N is the number of rows and columns of H.
*          N >= 0.
*
*  STEPS   (global input) INTEGER
*          The number of Lanczos steps.
*
*  A       (local input) COMPLEX*16 pointer into the local memory
*          to an array of dimension (LLD_A, LOCc(JA+N-1)).
*          This array contains the local pieces of the N-by-N Hermitian
*          distributed matrix sub( A ). The leading N-by-N lower
*          triangular part of sub( A ) contains the lower triangular
*          part of the distributed matrix, and its strictly upper
*          triangular part is not referenced.
*
*  IA      (global input) INTEGER
*          The row index in the global array A indicating the first
*          row of sub( A ).
*
*  JA      (global input) INTEGER
*          The column index in the global array A indicating the
*          first column of sub( A ).
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix A.
*
*  B       (local input) COMPLEX*16 pointer into the local memory
*          to an array of dimension (LLD_B, LOCc(JB+N-1)).
*          This array contains the local pieces of the N-by-N symmetric
*          distributed matrix sub( B ). The leading N-by-N lower
*          triangular part of sub( B ) contains the lower triangular
*          part of the distributed matrix, and its strictly upper
*          triangular part is not referenced.
*
*  IB      (global input) INTEGER
*          The row index in the global array B indicating the first
*          row of sub( B ).
*
*  JB      (global input) INTEGER
*          The column index in the global array B indicating the
*          first column of sub( B ).
*
*  DESCB   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix B.
*
*  X       (local input/output) COMPLEX*16 pointer into the local memory
*          to an array of dimension (LLD_X, LOCc(JX+1)).
*          On entry, X( 1:N, 1 ) is used to store the starting vector u,
*          which does not need to be normalized.
*          On exit, X( 1:N, j ) is used to store U( :, j ), while
*          X( N+1:2*N, j ) is used to store V( :, j ).
*
*  IX      (global input) INTEGER
*          The row index in the global array X indicating the first
*          row of sub( X ).
*          In this version, only IX = JX = 1 is supported.
*
*  JX      (global input) INTEGER
*          The column index in the global array X indicating the
*          first column of sub( X ).
*          In this version, only IX = JX = 1 is supported.
*
*  DESCX   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix X.
*
*  ALPHA   (global output) DOUBLE PRECISION array, dimension (STEPS)
*          The diagonal of the tridiagonal matrix T.
*
*  BETA    (global output) DOUBLE PRECISION array, dimension (STEPS)
*          The subdiagonal of the tridiagonal matrix T.
*
*  SCL     (global output) DOUBLE PRECISION
*          SCL = [ u; conj(u) ]**H * Omega * [ u; conj(u) ],
*          where u is the unnormalized starting vector on entry.
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          > 0:  Lanczos process breaks down after INFO steps.
*
*  Alignment requirements
*  ======================
*
*  The distributed matrices A, B, and X must satisfy the following
*  properties:
*
*     DESCA( MB_ ) = DESCA( NB_ )
*     DESCB( MB_ ) = DESCB( NB_ )
*     DESCA( MB_ ) = DESCB( MB_ ) = DESCX( MB_ )
*     DESCA( NB_ ) = DESCB( NB_ ) = DESCX( NB_ )
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
     $                   LLD_, MB_, M_, NB_, N_, RSRC_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                     CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                     RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CPLX_ZERO, CPLX_ONE
      PARAMETER          ( CPLX_ZERO = ( 0.0D+0, 0.0D+0 ),
     $                     CPLX_ONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            ICTXT, J
      DOUBLE PRECISION   DTMP, TMAX, TOL
      COMPLEX*16         ZTMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, DCMPLX, DSQRT, MAX
*     ..
*     .. External Functions ..
      EXTERNAL           PDLAMCH
      DOUBLE PRECISION   PDLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           PZAXPY, PZDSCAL, PZHEMM, PZSYMM, PZDOTC_ALL,
     $                   PZLACONJ
*
      INFO = 0
      ICTXT = DESCX( CTXT_ )
      TOL = 10*N*PDLAMCH( ICTXT, 'E' )
      TMAX = ZERO
*
*     V(:, 1) = A*U(:, 1) + B*conj(U(:, 1))
*     scl = real(U(:, 1)**H * V(:, 1))
*     U(:, 1) = U(:, 1)/sqrt(scl)
*     V(:, 1) = V(:, 1)/sqrt(scl)
*
      CALL PZHEMM( 'L', 'L', N, 1, CPLX_ONE, A, IA, JA, DESCA,
     $     X, IX, JX, DESCX, CPLX_ZERO, X, IX+N, JX, DESCX )
      CALL PZLACONJ( N, 1, X, IX, JX, DESCX )
      CALL PZSYMM( 'L', 'L', N, 1, CPLX_ONE, B, IB, JB, DESCB,
     $     X, IX, JX, DESCX, CPLX_ONE, X, IX+N, JX, DESCX )
      CALL PZLACONJ( N, 1, X, IX, JX, DESCX )
      CALL PZDOTC_ALL( N, ZTMP, X, IX, JX, DESCX, 1,
     $     X, IX+N, JX, DESCX, 1 )
      SCL = DBLE( ZTMP )
      CALL PZDSCAL( 2*N, DSQRT( ONE/SCL ), X, IX, JX, DESCX, 1 )
*
*     Lanczos process.
*
      DO J = 1, STEPS
*
*        First matrix vector multiplication.
*
*        U(:, j+1) = A*V(:, j) - B*conj(V(:, j))
*
         CALL PZHEMM( 'L', 'L', N, 1, CPLX_ONE, A, IA, JA, DESCA,
     $        X, IX+N, JX+J-1, DESCX, CPLX_ZERO, X, IX, JX+J, DESCX )
         CALL PZLACONJ( N, 1, X, IX+N, JX+J-1, DESCX )
         CALL PZSYMM( 'L', 'L', N, 1, -CPLX_ONE, B, IB, JB, DESCB,
     $        X, IX+N, JX+J-1, DESCX, CPLX_ONE, X, IX, JX+J, DESCX )
         CALL PZLACONJ( N, 1, X, IX+N, JX+J-1, DESCX )
*
*        Gram--Schmidt.
*
         IF ( J .GT. 1 ) THEN
*
*           U(:, j+1) = U(:, j+1) - beta(j-1)*U(:, j-1)
*
            CALL PZAXPY( N, DCMPLX( -BETA( J-1 ), ZERO ),
     $           X, IX, JX+J-2, DESCX, 1, X, IX, JX+J, DESCX, 1 )
         END IF
*
*        alpha(j) = real(V(:, j)**H * U(:, j+1))
*        U(:, j+1) = U(:, j+1) - alpha(j)*U(:, j)
*
         CALL PZDOTC_ALL( N, ZTMP, X, IX+N, JX+J-1, DESCX, 1,
     $        X, IX, JX+J, DESCX, 1 )
         ALPHA( J ) = DBLE( ZTMP )
         TMAX = MAX( TMAX, ALPHA( J ) )
         CALL PZAXPY( N, DCMPLX( -ALPHA( J ), ZERO ),
     $        X, IX, JX+J-1, DESCX, 1, X, IX, JX+J, DESCX, 1 )
*
*        Second matrix vector multiplication.
*
*        V(:, j+1) = A*U(:, j+1) + B*conj(U(:, j+1))
*
         CALL PZHEMM( 'L', 'L', N, 1, CPLX_ONE, A, IA, JA, DESCA,
     $        X, IX, JX+J, DESCX, CPLX_ZERO, X, IX+N, JX+J, DESCX )
         CALL PZLACONJ( N, 1, X, IX, JX+J, DESCX )
         CALL PZSYMM( 'L', 'L', N, 1, CPLX_ONE, B, IB, JB, DESCB,
     $        X, IX, JX+J, DESCX, CPLX_ONE, X, IX+N, JX+J, DESCX )
         CALL PZLACONJ( N, 1, X, IX, JX+J, DESCX )
*
*        Normalization.
*
*        beta(j) = sqrt(real(U(:, j+1)**H * V(:, j+1)))
*        U(:, j+1) = U(:, j+1)/beta(j)
*        V(:, j+1) = V(:, j+1)/beta(j)
*
         CALL PZDOTC_ALL( N, ZTMP, X, IX, JX+J, DESCX, 1,
     $        X, IX+N, JX+J, DESCX, 1 )
         DTMP = MAX( ZERO, DBLE( ZTMP ) )
         BETA( J ) = DSQRT( DTMP )
         IF ( BETA( J ) .GT. TOL*TMAX ) THEN
            CALL PZDSCAL( 2*N, DSQRT( ONE/DTMP ), X, IX, JX+J, DESCX,
     $           1 )
            TMAX = MAX( TMAX, BETA( J ) )
         ELSE
*
*           Breakdown of Lanczos process.
*
            BETA( J ) = ZERO
            INFO = J
            EXIT
         END IF
      END DO
*
      RETURN
*
*     End of PZBSLANCZOS().
*
      END

ext: f


text:
! { dg-do run }
! { dg-options "-fbackslash" }

  call testme(test("foo"), test4(4_"foo"), 1)
  call testme(test(""), test4(4_""), 1)
  call testme(test("gee"), test4(4_"gee"), 4)
  call testme(test("bar"), test4(4_"bar"), 1)
  call testme(test("magi"), test4(4_"magi"), 4)
  call testme(test("magic"), test4(4_"magic"), 2)
  call testme(test("magic   "), test4(4_"magic   "), 2)
  call testme(test("magica"), test4(4_"magica"), 4)
  call testme(test("freeze"), test4(4_"freeze"), 3)
  call testme(test("freeze "), test4(4_"freeze "), 3)
  call testme(test("frugal"), test4(4_"frugal"), 3)
  call testme(test("frugal "), test4(4_"frugal "), 3)
  call testme(test("frugal \x01"), test4(4_"frugal \x01"), 3)
  call testme(test("frugal \xFF"), test4(4_"frugal \xFF"), 4)

contains
  integer function test(s)
    character(len=*) :: s

    select case (s)
      case ("":"foo")
        test = 1
      case ("magic")
        test = 2
      case ("freeze":"frugal")
        test = 3
      case default
        test = 4
    end select
  end function test

  integer function test4(s)
    character(kind=4,len=*) :: s

    select case (s)
      case (4_"":4_"foo")
        test4 = 1
      case (4_"magic")
        test4 = 2
      case (4_"freeze":4_"frugal")
        test4 = 3
      case default
        test4 = 4
    end select
  end function test4

  subroutine testme(x,y,z)
    integer :: x, y, z
    if (x /= y) call abort
    if (x /= z) call abort
  end subroutine testme
end

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
!!Quick routine to wrap the SLALIB moon position function.
!!It is inaccurate but fine for QUIJOTE accuracy. It downsamples
!! the data by 100x!

subroutine rdplan(jd, np, lon, lat, ra, dec, diam, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  real*8, intent(in) :: lon
  real*8, intent(in) :: lat
  integer, intent(in) :: np
  real*8, intent(in) :: jd(len_bn)
  real*8, intent(out) :: diam(len_bn)
  real*8, intent(out) :: ra(len_bn)
  real*8, intent(out) :: dec(len_bn)

  !f2py integer len_bn
  !f2py real*8 lon, lat
  !f2py real*8 ra,dec,jd, diam

  !integer :: i

  real*8 :: pi = 3.14159265359

  integer :: step = 100
  integer :: kup,k
  kup = len_bn/step

  do k=1, len_bn
     call sla_rdplan(jd(k),np,lon*pi/180.0,lat*pi/180.0,ra(k),dec(k),diam(k))
  enddo

end subroutine rdplan

subroutine planet(jd, np, dist, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  integer, intent(in) :: np
  real*8, intent(in) :: jd(len_bn)
  real*8, intent(out) :: dist(6,len_bn)

  !f2py integer len_bn
  !f2py real*8 jd, dist

  integer :: jstat

  !real*8 :: pi = 3.14159265359

  integer :: step = 100
  integer :: kup,k
  kup = len_bn/step

  !mask = 1.0d0

  do k=1, len_bn
     call sla_planet(jd(k),np,dist(:,k),jstat)
  enddo

end subroutine planet

subroutine h2e(az, el, mjd, lon, lat, ra, dec, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  real*8, intent(in) :: lon
  real*8, intent(in) :: lat
  real*8, intent(in) :: az(len_bn)
  real*8, intent(in) :: el(len_bn)
  real*8, intent(in) :: mjd(len_bn)
  real*8, intent(out) :: ra(len_bn)
  real*8, intent(out) :: dec(len_bn)

  interface
     real*8 FUNCTION sla_gmst(mjddummy)
     real*8 :: mjddummy
     END FUNCTION sla_gmst
  end interface

  interface
     real*8 FUNCTION sla_dranrm(mjddummy)
     real*8 :: mjddummy
     END FUNCTION sla_dranrm
  end interface

  !f2py integer len_bn
  !f2py real*8 lon, lat
  !f2py real*8 ra,dec,mjd

  integer :: i

  real*8 :: gmst

  do i=1, len_bn
     call sla_dh2e(az(i), el(i), lat, ra(i), dec(i))
     gmst = sla_gmst(mjd(i))
     ra(i) = gmst + lon - ra(i)
     ra(i) = sla_dranrm(ra(i))
  enddo

end subroutine h2e

subroutine precess(ra, dec,mjd, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  real*8, intent(in) :: mjd(len_bn)
  real*8, intent(inout) :: ra(len_bn)
  real*8, intent(inout) :: dec(len_bn)

  interface
     real*8 FUNCTION sla_epb(mjddummy)
     real*8 :: mjddummy
     END FUNCTION sla_epb
  end interface

  !f2py integer len_bn
  !f2py real*8 mjd
  !f2py real*8 ra,dec

  integer :: i
  real*8 :: epoch

  do i=1, len_bn
     epoch = sla_epb(mjd(i))
     call sla_preces('FK5', epoch, 2000D0, ra(i), dec(i))
  enddo

end subroutine precess

subroutine pa(ra, dec,mjd, lon,lat,pang, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  real*8, intent(in) :: lon
  real*8, intent(in) :: lat
  real*8, intent(in) :: mjd(len_bn)
  real*8, intent(in) :: ra(len_bn)
  real*8, intent(in) :: dec(len_bn)
  real*8, intent(out) :: pang(len_bn)

  interface
     real*8 FUNCTION sla_gmst(mjddummy)
     real*8 :: mjddummy
     END FUNCTION sla_gmst
  end interface

  interface
     real*8 FUNCTION sla_pa(radummy, decdummy, phidummy)
     real*8 :: radummy, decdummy, phidummy
     END FUNCTION sla_pa
  end interface

  !f2py integer len_bn
  !f2py real*8 mjd, lon, lat
  !f2py real*8 ra,dec, pang

  integer :: i
  real*8 :: ha, gmst

  do i=1, len_bn
     gmst = sla_gmst(mjd(i))
     ha = gmst + lon - ra(i)
     pang(i) = sla_pa(ha, dec(i), lat)
  enddo

end subroutine pa

subroutine e2g(ra, dec, gl, gb, len_bn)
  implicit none

  integer, intent(in) :: len_bn
  real*8, intent(in) :: ra(len_bn)
  real*8, intent(in) :: dec(len_bn)
  real*8, intent(out) :: gl(len_bn)
  real*8, intent(out) :: gb(len_bn)

  !f2py integer len_bn
  !f2py real*8 ra,dec,gl,gb

  integer :: i

  do i=1, len_bn
     call sla_eqgal(ra(i), dec(i), gl(i), gb(i))
  enddo

end subroutine e2g

max_stars_repo_name: SharperJBCA/COMAPAnalysis

max_issues_repo_name: SharperJBCA/COMAPAnalysis

max_forks_repo_name: SharperJBCA/COMAPAnalysis


text:
	SUBROUTINE HSDATT  ( iunit, fname, ictype, xsize, ysize,
     +			     ncurwn, iret )
C************************************************************************
C* HSDATT - GIF 							*
C* 									*
C* This subroutine defines the device attributes.			*
C* 									*
C* HSDATT  ( IUNIT, FNAME, ICTYPE, XSIZE, YSIZE, 			*
C*		NCURWN, IRET )						*
C*									*
C* Input parameters:							*
C*	IUNIT		INTEGER		Unit				*
C*	FNAME		CHAR*		File/window name		*
C*      ICTYPE          INTEGER         Device type (color,bw,etc)      *
C*      XSIZE           REAL            X size in inches or pixels      *
C*      YSIZE           REAL            Y size in inches or pixels      *
C*                                                                      *
C* Output parameters:							*
C*	NCURWN		INTEGER		Window number			*
C* 	IRET		INTEGER		Return code			*
C*					  NORMAL = no change to att's	*
C*					  NWSIZE = Device att's changed	*
C*					  NIDSIZ = Invalid device size	*
C**									*
C* Log:									*
C* J. Cowie/COMET	 9/95	Added other attributes.			*
C* J. Cowie/COMET	 2/96	Fixed pop mode change bug		*
C* J. Nielsen-G/TAMU	12/96	Modified for GIF driver			*
C* T. Lee/GSC		 7/00	Called wclosp				*
C* R. Tian/SAIC		05/02	Fixed memory fault			*
C* S. Jacobs/NCEP	 2/03	Changed return value to not be from 	*
C*				HSCINT, but for new window or size	*
C************************************************************************
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'driver.cmn'
C*
	CHARACTER*(*)	fname
C*
C------------------------------------------------------------------------
	iret = NORMAL
	ncurwn = 1
        IF ( ( xsize .GT. 1 ) .AND. ( xsize .LT. 5001 )
     +       .AND. ( ysize .GT. 1 ) .AND. ( ysize .LT. 5001 ) )  THEN
          ir = NINT ( xsize ) - 1
          ib = NINT ( ysize ) - 1
        ELSE
	  ir = 639
	  ib = 479
        END IF
C
C*	See if the GIF characteristics have changed.  If so, dump out to
C*	the current file if needed.
C
        IF ( ( (fname .ne. ' ') .and. (fname .ne. filnam) ) .or.
     +	     ( ( xsize .ne. RMISSD .or. ysize .ne. RMISSD ) .and.
     +	       ( ir .ne. iright .or. ib .ne. ibot ) ) )  THEN

            CALL WCLOSP ( filnam, gfplot, iret )
            gfplot = .false.
C
C*	    Update filename.
C
	    IF ( fname .ne. ' ') THEN
		filnam = fname
		iret   = NEWWIN
	    ELSE
		filnam = 'gempak.gif'
		iret   = NEWWIN
	    END IF
C
C*	    Update window size.
C
	    IF ( (xsize .ne. RMISSD) .or. (ysize .ne. RMISSD) ) THEN
		iright = ir
		ibot   = ib
		iret   = NWSIZE
	    END IF

C
C*	    Update unit.
C
	    IF ( (iunit .NE. RMISSD) .and. (iunit .GT. 0) )  THEN
		niunit = iunit
	    END IF

C
C*	    Open plot and reset colors
C
	    opnfil = .false.
	    gfplot = .false.
C
	    CALL HSCINT ( ier )
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      program prog
      c=a+i
      end


!
!  Copyright 2017 SALMON developers
!
!  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.
!
subroutine copy_density
use scf_data
implicit none
integer :: iiter
integer :: is

if(Miter==1)then
  rho_in(:,:,:,num_rho_stock+1)=rho(:,:,:)
  if(ilsda==1)then
    rho_s_in(:,:,:,1:2,num_rho_stock+1)=rho_s(:,:,:,1:2)
  end if
end if

do iiter=1,num_rho_stock
  rho_in(:,:,:,iiter)=rho_in(:,:,:,iiter+1)
end do
do iiter=1,num_rho_stock-1
  rho_out(:,:,:,iiter)=rho_out(:,:,:,iiter+1)
end do

if(ilsda==1)then
  do iiter=1,num_rho_stock
    do is=1,2
      rho_s_in(:,:,:,is,iiter)=rho_s_in(:,:,:,is,iiter+1)
    end do
  end do
  do iiter=1,num_rho_stock-1
    do is=1,2
      rho_s_out(:,:,:,is,iiter)=rho_s_out(:,:,:,is,iiter+1)
    end do
  end do
end if

end subroutine copy_density


text:
C File: test_module_03.f
C Purpose: Illustrates the use of multiple Fortran modules to define values
C    for several variables that are used in the program.
C
C Compile and run this program as follows:
C
C    gfortran -c test_module_03.f     # << this will create files "mymod3.mod"
C                                                                 "mymod4.mod"
C                                                                 "mymod5.mod"
C    gfortran test_module_03.f        # << this will create a file "a.out"
C
C The output generated by this program is (see test_module_03-OUT.txt):
C
C   1234    2  3.1416 7753.469

!-------------------------------------------------------------------------------
      MODULE MYMOD3
      IMPLICIT NONE

      INTEGER :: X = 1234
      END MODULE mymod3

!-------------------------------------------------------------------------------
      MODULE MYMOD4
      IMPLICIT NONE

      INTEGER :: Y = 2
      END MODULE mymod4

!-------------------------------------------------------------------------------
      MODULE MYMOD5
      IMPLICIT NONE

      REAL :: PI = 3.1416
      END MODULE mymod5

!-------------------------------------------------------------------------------
      PROGRAM PGM
      USE mymod3
      USE mymod4
      USE mymod5

  10   FORMAT (I7, I5, F8.4, F9.3)

      write (*,10) X, Y, PI, X*Y*PI

      stop
      end program PGM
!-------------------------------------------------------------------------------

max_stars_repo_name: cthoyt/delphi

max_issues_repo_name: cthoyt/delphi

max_forks_repo_name: cthoyt/delphi