text:
module m_ex_to_vx
   USE m_judft
   USE m_types
   USE m_symmetrizeh

contains
   subroutine ex_to_vx(fi, nk, jsp, nsymop, psym, hybdat, lapw, z, ex, v_x)
      use m_juDFT
      use m_eig66_io
      implicit none

      type(t_fleurinput), intent(in)    :: fi

      TYPE(t_hybdat), INTENT(inout) :: hybdat
      type(t_lapw), intent(in)      :: lapw
      integer, intent(in)           :: nk, jsp, nsymop, psym(fi%sym%nsym)
      TYPE(t_mat), intent(in)       :: z
      type(t_mat), intent(inout)    :: ex
      type(t_mat), intent(inout)    :: v_x

      integer     :: nbasfcn
      type(t_mat) :: trafo, tmp, olap

      CALL timestart("T^-1*mat_ex*T^-1*")
      nbasfcn = lapw%hyb_num_bas_fun(fi)

      !calculate trafo from wavefunctions to APW basis
      IF (fi%input%neig < hybdat%nbands(nk)) call judft_error(' mhsfock: neigd  < nbands(nk) ;trafo from wavefunctions to APW requires at least nbands(nk)')

      call ex%u2l()

      call olap%init(z%l_real, z%matsize1, z%matsize1)
      CALL read_eig(hybdat%eig_id,nk,jsp, smat=olap)
      call olap%u2l()
      call olap%conjugate()

      call olap%multiply(z, trafo)

      CALL ex%multiply(trafo, res=tmp, transB="C")
      CALL trafo%multiply(tmp, res=v_x)

      CALL timestop("T^-1*mat_ex*T^-1*")

      call timestart("symmetrizeh")
      CALL symmetrizeh(fi%atoms, fi%kpts%bkf(:, nk), jsp, lapw, fi%sym, hybdat%kveclo_eig, fi%cell, nsymop, psym, v_x)
      call timestop("symmetrizeh")
   end subroutine ex_to_vx
end module

max_stars_repo_name: MRedies/FLEUR

max_issues_repo_name: MRedies/FLEUR

max_forks_repo_name: MRedies/FLEUR


text:
http://img.photobucket.com/albums/v88/vox_furor/joeys%20better%20retreat%20pics/000_0017.jpg

Name: Eric Tyler Felix

English and Film Studies double major, Education minor.

AIM: dcty

Student Housing Diversity Intern 0506, Davis Senior High English Intern 0406, Campus NOW (National Organization for Women) Public Relations Chair 0506, Coordinator 0607, MAAR (Men Acting Against Rape) Outreach Chair, exResident Advisor (Castilian Hall Castilian North Court 0304, Leach Hall 0405), MIP (Multicultural Immersion Program) intern 0607.  Upward Bound Student Assistant 0607.  Tercero Area Service Desk worker 0507 or whenever I graduate.

Fun Facts:

UC Davis will continue to own his life since its the only place he got into grad school.

Specializes in 1.5 in. thick platesized cakes right off the pan.

20070413 01:15:15 nbsp Where you are you from origionally Users/StevenDaubert

20070506 16:31:50 nbsp i am i from san diego origionally Users/TylerFelix

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
c
c
c     =====================================================
      subroutine cudaclaw_flux_add(mx,my,mbc,meqn,dx,dy,
     &      dt, qnew,flux,iface, buffer)
c     =====================================================

      implicit none

      integer mx,my,mbc,meqn, iface
      double precision dx,dy, dt
      double precision qnew(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision flux(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)
      double precision buffer(max(mx,my),meqn)

      integer i,j,m

      do m = 1,meqn
         if (iface == 0) then
            do j = 1,my
               buffer(j,m) = buffer(j,m) + flux(1,j,m)
            enddo
         endif

         if (iface == 1) then
            do j = 1,my
               buffer(j,m) = buffer(j,m) + flux(mx+1,j,m)
            enddo
         endif

         if (iface == 2) then
            do i = 1,mx
               buffer(i,m) = buffer(i,m) + flux(i,1,m)
            enddo
         endif

         if (iface == 3) then
            do i = 1,mx
               buffer(i,m) = buffer(i,m) + flux(i,my+1,m)
            enddo
         endif

      enddo

      end

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
! $Id: num_rec.f90,v 1.1 2008-07-24 17:31:45 dschanen Exp $
!   From _Numerical Recipes in Fortran 90_
!   (C) 1988-1996 Numerical Recipes Software
MODULE nrtype

INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
INTEGER, PARAMETER :: SP  = KIND(1.0)
INTEGER, PARAMETER :: DP  = KIND(1.0D0)
INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
INTEGER, PARAMETER :: LGT = KIND(.true.)

REAL(SP), PARAMETER :: PI      = 3.141592653589793238462643383279502884197_sp
REAL(SP), PARAMETER :: PIO2    = 1.57079632679489661923132169163975144209858_sp
REAL(SP), PARAMETER :: TWOPI   = 6.283185307179586476925286766559005768394_sp
REAL(SP), PARAMETER :: SQRT2   = 1.41421356237309504880168872420969807856967_sp
REAL(SP), PARAMETER :: EULER   = 0.5772156649015328606065120900824024310422_sp
REAL(DP), PARAMETER :: PI_D    = 3.141592653589793238462643383279502884197_dp
REAL(DP), PARAMETER :: PIO2_D  = 1.57079632679489661923132169163975144209858_dp
REAL(DP), PARAMETER :: TWOPI_D = 6.283185307179586476925286766559005768394_dp

TYPE sprs2_sp
  INTEGER(I4B)                        :: n, len
  REAL(SP), DIMENSION(:), POINTER     :: val
  INTEGER(I4B), DIMENSION(:), POINTER :: irow
  INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_sp

TYPE sprs2_dp
  INTEGER(I4B)                        :: n, len
  REAL(DP), DIMENSION(:), POINTER     :: val
  INTEGER(I4B), DIMENSION(:), POINTER :: irow
  INTEGER(I4B), DIMENSION(:), POINTER :: jcol
END TYPE sprs2_dp

END MODULE nrtype

max_stars_repo_licenses: Intel Unlicense NetCDF

max_issues_repo_licenses: Intel Unlicense NetCDF

max_forks_repo_licenses: Intel Unlicense NetCDF


text:
! Test EXIT with dynamically optional arguments.
! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPexit_opt_dummy(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "status", fir.optional}) {
subroutine exit_opt_dummy(status)
  integer, optional :: status
  call exit(status)
! CHECK:  %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.ref<i32>) -> i1
! CHECK:  %[[VAL_2:.*]] = fir.if %[[VAL_1]] -> (i32) {
! CHECK:    %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
! CHECK:    fir.result %[[VAL_3]] : i32
! CHECK:  } else {
! CHECK:    %[[VAL_4:.*]] = arith.constant 0 : i32
! CHECK:    fir.result %[[VAL_4]] : i32
! CHECK:  }
! CHECK:  %[[VAL_5:.*]] = fir.call @_FortranAExit(%[[VAL_6:.*]]) : (i32) -> none
end subroutine

! CHECK-LABEL: func @_QPexit_pointer(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<i32>>> {fir.bindc_name = "status"}) {
subroutine exit_pointer(status)
  integer, pointer :: status
  call exit(status)
! CHECK:  %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK:  %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ptr<i32>) -> i64
! CHECK:  %[[VAL_4:.*]] = arith.constant 0 : i64
! CHECK:  %[[VAL_5:.*]] = arith.cmpi ne, %[[VAL_3]], %[[VAL_4]] : i64
! CHECK:  %[[VAL_6:.*]] = fir.if %[[VAL_5]] -> (i32) {
! CHECK:    %[[VAL_7:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<i32>>>
! CHECK:    %[[VAL_8:.*]] = fir.box_addr %[[VAL_7]] : (!fir.box<!fir.ptr<i32>>) -> !fir.ptr<i32>
! CHECK:    %[[VAL_9:.*]] = fir.load %[[VAL_8]] : !fir.ptr<i32>
! CHECK:    fir.result %[[VAL_9]] : i32
! CHECK:  } else {
! CHECK:    %[[VAL_10:.*]] = arith.constant 0 : i32
! CHECK:    fir.result %[[VAL_10]] : i32
! CHECK:  }
! CHECK:  %[[VAL_11:.*]] = fir.call @_FortranAExit(%[[VAL_12:.*]]) : (i32) -> none
end subroutine

max_stars_repo_name: ornata/llvm-project

max_issues_repo_name: ornata/llvm-project

max_forks_repo_name: ornata/llvm-project


module get_date_mod

  use netcdf_driver_mod, only: ncfile_type, time_axis_index, &
                               get_axis_units, get_calendar_type

  use  time_manager_mod, only: time_type, set_date, get_date,   &
                               set_time, set_calendar_type,     &
                               operator(+), JULIAN, NO_LEAP,    &
                               THIRTY_DAY_MONTHS

  use     utilities_mod, only: error_mesg

  implicit none
  private

  public :: current_date
!!public :: get_ref_date, increment_date, to_time_type

contains

!#######################################################################

 subroutine get_ref_date (units, date)

  character(len=*), intent(in)  :: units
  integer         , intent(out) :: date(6)

  integer :: is, ie

!---- returns the reference date from time units label ----
!---- note: this version requires a specific format ----

  date = 0

  is = index(units, 'since')

  if ( is > 0 ) then
       ie = is + 24
       read (units(is:ie),10) date(1:6)
 10    format (6x,i4,5(1x,i2))
  endif

 end subroutine get_ref_date

!#######################################################################

 subroutine increment_date (units, dt, date1, date2)

  character(len=*), intent(in)  :: units
  real,             intent(in)  :: dt
  integer,          intent(in)  :: date1(6)
  integer,          intent(out) :: date2(6)

  type(time_type) :: Time

!---- increments date1 by dt using time units label -----

  Time = set_date (date1(1), date1(2), date1(3), &
                   date1(4), date1(5), date1(6)) &
         + to_time_type (units,dt)

  call get_date (Time, date2(1), date2(2), date2(3), &
                       date2(4), date2(5), date2(6)  )

  date2(4) = get_hour(units,dt)

 end subroutine increment_date

!#######################################################################

 function to_time_type (units, time_since) result (Time)

   character(len=*), intent(in) :: units
   real            , intent(in) :: time_since
   type(time_type)              :: Time

   integer :: nc
   real    :: dfac

!---- convert time_since to time_type ----
!---- valid time units are: seconds,minutes,hours,days -----

      nc = len_trim(units)

      if (index(units(1:nc),'sec') > 0) then
           dfac = 86400.
      else if (index(units(1:nc),'min') > 0) then
           dfac = 1440.
      else if (index(units(1:nc),'hour') > 0) then
           dfac = 24.
      else if (index(units(1:nc),'day') > 0) then
           dfac = 1.
      else
           call error_mesg ('to_time_type', 'invalid time units', 2)
           dfac = 1.
      endif

          Time = set_time (0,int(time_since/dfac))

 end function to_time_type

!#######################################################################
!#######################################################################

 function get_hour (units, time_since) result (hour)

   character(len=*), intent(in) :: units
   real            , intent(in) :: time_since
   integer :: nc
   real    :: rday, dfac
   integer :: hour

!---- convert time_since to time_type ----
!---- valid time units are: seconds,minutes,hours,days -----

      nc = len_trim(units)

      if (index(units(1:nc),'sec') > 0) then
           dfac = 86400.
      else if (index(units(1:nc),'min') > 0) then
           dfac = 1440.
      else if (index(units(1:nc),'hour') > 0) then
           dfac = 24.
      else if (index(units(1:nc),'day') > 0) then
           dfac = 1.
      else
           call error_mesg ('to_time_type', 'invalid time units', 2)
           dfac = 1.
      endif

            rday = time_since/dfac
            hour = nint( 24.0*(rday - int(rday)) )

 end function get_hour

!#######################################################################
!#######################################################################

 subroutine current_date (File, time_since, date)

  type(ncfile_type), intent(in)  :: File
  real,              intent(in)  :: time_since
  integer,           intent(out) :: date(6)

!  File       = ncfile_type from previous call to
!               read_file_header or write_file_header
!  time_since = time axis value
!  date       = date, dimension(6)=(year,month,day,hour,minute,seconds)

  integer :: axis, idate(6)
  logical :: uflag, cflag
  character(len=128) :: units, calendar

    date = 0
    axis = time_axis_index (File)

    uflag = get_axis_units    (File, axis, units)
    cflag = get_calendar_type (File, axis, calendar)

!---- no units, so return ----
    if (.not.uflag) return

!---- set calendar (default Julian ?) ----
    if (cflag) then
        call set_cal (calendar)
    else
        call set_cal ('NOLEAP')
    endif

!---- get reference date and increment using time_since ----

    call get_ref_date (units, idate)

    call increment_date (units, time_since, idate, date)

 end subroutine current_date

!#######################################################################

 subroutine set_cal (cal)

   character(len=*), intent(in) :: cal

    if (cal(1:6) == 'Julian'    .or.  &
        cal(1:6) == 'julian'    .or.  &
        cal(1:6) == 'JULIAN'    .or.  &
        cal(1:9) == 'Gregorian' .or.  &
        cal(1:9) == 'gregorian' .or.  &
        cal(1:9) == 'GREGORIAN' ) then
               call set_calendar_type (JULIAN)

!    else if (cal(1:6) == 'common') then
     else if (cal(1:6) == 'NOLEAP') then
               call set_calendar_type (NO_LEAP)

     else
!              call set_calendar_type (THIRTY_DAY_MONTHS)
               call set_calendar_type (NO_LEAP)
     endif

 end subroutine set_cal

!#######################################################################

end module get_date_mod


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

C=======================================================================
      SUBROUTINE DELCMD (INLINE, INTYP, CFIELD, *)
C=======================================================================

C   --*** DELCMD *** (ALGEBRA) Perform DELETE command
C   --   Written by Amy Gilkey - revised 11/23/87
C   --
C   --DELCMD processes the input DELETE command.  It sets the ISTVAR
C   --flag in the /VAR../ arrays for all deleted variables.
C   --
C   --Parameters:
C   --   INLINE - IN/OUT - the parsed input lines for the log file
C   --   INTYP - IN - the field types
C   --   CFIELD - IN - the character fields
C   --   * - return statement if command not executed
C   --
C   --Common Variables:
C   --   Uses IXLHS, NAMVAR of /VAR../
C   --   Sets ISTVAR of /VAR../

      PARAMETER (ICURTM = 1, ILSTTM = 2, IONETM = 3)
      include 'ag_namlen.blk'
      include 'ag_var.blk'
C     database type, num_of qa and info records
      include 'ag_dbnumq.blk'

      CHARACTER*(*) INLINE
      INTEGER INTYP(*)
      CHARACTER*(*) CFIELD(*)

      LOGICAL FFEXST, MATSTR
      CHARACTER*(maxnam) NAME

      NUMLHS = MAXVAR - IXLHS + 1

      IFLD = 1
  100 CONTINUE
      IF (FFEXST (IFLD, INTYP)) THEN

         CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', NAME)

         IF (MATSTR (NAME, 'QAINFO', 6)) THEN
           NQAREC = 0
           NINFO  = 0
         ELSE IF (MATSTR (NAME, 'QA', 2)) THEN
           NQAREC = 0
         ELSE IF (MATSTR (NAME, 'INFORMATION', 11)) THEN
           NINFO  = 0
         ELSE
           IVAR = LOCSTR (NAME, NUMLHS, NAMVAR(IXLHS))
           IF (IVAR .EQ. 0) THEN
             CALL PRTERR ('CMDERR',
     &         '"' // NAME(:LENSTR(NAME)) // '" not defined, ignored')
             GOTO 110
           END IF
           ISTVAR(ICURTM,IVAR+IXLHS-1) = -1
         END IF
         CALL FFADDC (NAME, INLINE)

  110    CONTINUE
         GOTO 100
      END IF

      RETURN
      END

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
      subroutine elliptic2d(cmo,mpary,mpno,ctrl,ierror)
c
c #####################################################################
c
c     purpose -
c
c     ELLIPTIC2d smooths 2d mesh objects using
c     elliptic smoothing.  We do not attempt
c     to inhibit flipping of element orientations.
c
c     input arguments -
c
c         cmo - name of current mesh object
c         mpary - array of nodes to be smoothed
c         mpno - length of mpary
c         ctrl - control parameter for controlled smoothing
c
c     output arguments -
c
c         ierror - error return code (==0 ==> ok, <>0 ==> error)
c
c     change history -
c
c        $Log: elliptic2d.f,v $
c        Revision 2.00  2007/11/05 19:45:53  spchu
c        Import to CVS
c
CPVCS
CPVCS       Rev 1.0   08 Feb 2000 09:56:34   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.0   31 Jan 2000 17:11:40   kuprat
CPVCS    Initial revision.
c
c #####################################################################

      implicit none

      include 'local_element.h'
      include 'consts.h'

      integer lenptr
      parameter (lenptr=1000000)

      integer mpary(lenptr)

      character*132 logmess

      pointer (ipitp1, itp1)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      pointer (ipitet, itet)
      pointer (ipitetoff, itetoff)
      pointer (ipitettyp, itettyp)

      integer itp1(lenptr)
      real*8 xic(lenptr)
      real*8 yic(lenptr)
      real*8 zic(lenptr)
      integer itet(lenptr)
      integer itetoff(lenptr)
      integer itettyp(lenptr)

      pointer (ipxsave,xsave), (ipysave,ysave), (ipzsave,zsave)
      real*8 xsave(lenptr), ysave(lenptr), zsave(lenptr)

      pointer (ipireal1,ireal1)
      integer ireal1(lenptr)
      pointer (ipout,out)

      pointer (ipnoditet,noditet), (ipnoditetoff,noditetoff)
      integer noditet(2,lenptr), noditetoff(lenptr)

      real*8 tn1(3),tni(3),area(3),ctrl,x1,y1,z1,
     &   x2,y2,z2,x3,y3,z3,dcross,areamin,areamax,epsilonl,
     &   tolconv_sm,err,xold,yold,zold,
     &   err1,dcrossp,areaminp,areamaxp,wt,asq,dsq,xnew,ynew,
     &   znew,weight,out(*)

      integer mpno,ierror,nnodes,length,icmotype,nelements,
     &   mbndry,ilen,ityp,icscode,nod1,nod2,nod3,nod4,ierrw,
     &   i,ioff,maxiter_sm,itypconv_sm,k,iter,ierrdum,ntri,
     &   nqud,nsimp,nnitet,iout

      real*8 epsilona

      character*32 cmo,cout
      character*32 isubname

      real*8 x1_,y1_,z1_,x2_,y2_,z2_,x3_,y3_,z3_,crosx,crosy,crosz

c statement functions for the components of the cross product
c ((x2,y2,z2)-(x1,y1,z1)) x ((x3,y3,z3)-(x1,y1,z1)) .

      crosx(x1_,y1_,z1_,x2_,y2_,z2_,x3_,y3_,z3_)=(y2_-y1_)*(z3_-z1_)
     &   -(z2_-z1_)*(y3_-y1_)
      crosy(x1_,y1_,z1_,x2_,y2_,z2_,x3_,y3_,z3_)=(z2_-z1_)*(x3_-x1_)
     &   -(x2_-x1_)*(z3_-z1_)
      crosz(x1_,y1_,z1_,x2_,y2_,z2_,x3_,y3_,z3_)=(x2_-x1_)*(y3_-y1_)
     &   -(y2_-y1_)*(x3_-x1_)

      isubname = 'elliptic2d'
      ierror=0

c  get info from mesh object to be smoothed
      call cmo_get_info('nnodes',cmo,
     *   nnodes,length,icmotype,ierror)
      call cmo_get_info('nelements',cmo,
     *   nelements,length,icmotype,ierror)
      call cmo_get_info('mbndry',cmo,
     *   mbndry,length,icmotype,ierror)
      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierror)
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierror)
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierror)
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierror)
      call cmo_get_info('itet',cmo,ipitet,ilen,ityp,ierror)
      call cmo_get_info('itetoff',cmo,ipitetoff,ilen,ityp,ierror)
      call cmo_get_info('itettyp',cmo,ipitettyp,ilen,ityp,ierror)

c...  get epsilon length.

      call get_epsilon('epsilonl', epsilonl)
      print*,'epsilonl=',epsilonl

c...  compute epsilon area.  The expression in brackets is the
c...  epsilon length divided by the machine epsilon... this
c...  ought to be the characteristic length of the grid.

      epsilona=epsilonl*(epsilonl/1.d-8)
      print*,'epsilona=',epsilona

C        1) Do we have a real point?
C             ireal1() =  0 ==> not a real point.
C             ireal1() =  1 ==> a real point.
C

      call mmgetblk('ireal1',isubname,ipireal1,nnodes,1,icscode)
      call unpacktp("allreal","set",nnodes,ipitp1,ipireal1,ierrdum)
      if(ierrdum.ne.0) call x3d_error(isubname, 'unpacktp')

c  Compute a unit normal for the 'whole mesh' by adding up all the
c  area vectors for all the elements and normalizing.

      tn1(1)=0.
      tn1(2)=0.
      tn1(3)=0.
      do i=1,nelements
         ioff=itetoff(i)
         nod1=itet(1+ioff)
         nod2=itet(2+ioff)
         nod3=itet(3+ioff)
         x1=xic(nod1)
         y1=yic(nod1)
         z1=zic(nod1)
         x2=xic(nod2)
         y2=yic(nod2)
         z2=zic(nod2)
         x3=xic(nod3)
         y3=yic(nod3)
         z3=zic(nod3)
         tni(1)=crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(2)=crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(3)=crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         if (itettyp(i).eq.ifelmqud) then
            nod4=itet(4+ioff)
            x1=xic(nod3)
            y1=yic(nod3)
            z1=zic(nod3)
            x2=xic(nod4)
            y2=yic(nod4)
            z2=zic(nod4)
            x3=xic(nod1)
            y3=yic(nod1)
            z3=zic(nod1)
            tni(1)=tni(1)+crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(2)=tni(2)+crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(3)=tni(3)+crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         endif

         tn1(1)=tn1(1)+tni(1)
         tn1(2)=tn1(2)+tni(2)
         tn1(3)=tn1(3)+tni(3)

      enddo

      dcross=sqrt(tn1(1)**2+tn1(2)**2+tn1(3)**2)

      if (dcross.lt.2*epsilona) then

         write(logmess,'(a)')
     *      'elliptic2d: Cannot get a single unit normal for mesh.'
         call writloga('default',0,logmess,0,ierrw)

      else

         tn1(1)=tn1(1)/dcross
         tn1(2)=tn1(2)/dcross
         tn1(3)=tn1(3)/dcross

      endif

      areamin=1.d99
      areamax=-1.d99
      areaminp=1.d99
      areamaxp=-1.d99
      do i=1,nelements
         ioff=itetoff(i)
         nod1=itet(1+ioff)
         nod2=itet(2+ioff)
         nod3=itet(3+ioff)
         x1=xic(nod1)
         y1=yic(nod1)
         z1=zic(nod1)
         x2=xic(nod2)
         y2=yic(nod2)
         z2=zic(nod2)
         x3=xic(nod3)
         y3=yic(nod3)
         z3=zic(nod3)
         tni(1)=crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(2)=crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(3)=crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         if (itettyp(i).eq.ifelmqud) then
            nod4=itet(4+ioff)
            x1=xic(nod3)
            y1=yic(nod3)
            z1=zic(nod3)
            x2=xic(nod4)
            y2=yic(nod4)
            z2=zic(nod4)
            x3=xic(nod1)
            y3=yic(nod1)
            z3=zic(nod1)
            tni(1)=tni(1)+crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(2)=tni(2)+crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(3)=tni(3)+crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         endif

         dcross=sqrt(tni(1)**2+tni(2)**2+tni(3)**2)

         areamin=min(areamin,dcross*0.5)
         areamax=max(areamax,dcross*0.5)

         dcrossp=tni(1)*tn1(1)+tni(2)*tn1(2)+tni(3)*tn1(3)

         areaminp=min(areaminp,dcrossp*0.5)
         areamaxp=max(areamaxp,dcrossp*0.5)

      enddo

      write(logmess,'(2(a,e14.7))')
     *   ' min/max area before smoothing=',areamin,' / ',areamax
      call writloga('default',0,logmess,0,ierrw)
      write(logmess,'(2(a,e14.7))')
     *   ' min/max projected area before smoothing=',
     &   areaminp,' / ',areamaxp
      call writloga('default',0,logmess,0,ierrw)

c if we are using the 'control' option, we need to save the
c node positions of the unsmoothed mesh.
      if (ctrl.ne.0.) then
         call mmgetblk('xsave',isubname,ipxsave,mpno,2,icscode)
         call mmgetblk('ysave',isubname,ipysave,mpno,2,icscode)
         call mmgetblk('zsave',isubname,ipzsave,mpno,2,icscode)
         do i=1,mpno
            xsave(i)=xic(mpary(i))
            ysave(i)=yic(mpary(i))
            zsave(i)=zic(mpary(i))
         enddo
      endif

      call cmo_get_info('maxiter_sm',cmo,
     *   maxiter_sm,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
      call cmo_get_info('itypconv_sm',cmo,
     *   itypconv_sm,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'get_info_i')
      call cmo_get_attinfo('tolconv_sm',cmo,iout,
     *   tolconv_sm,cout,ipout,ilen,ityp,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'get_info_r')

      itypconv_sm=1
      tolconv_sm=.05

      write(logmess,'(a,i5)')
     *   'maxiter_sm=',maxiter_sm

c obtain node-itet relation.  (for a given node, the node-itet relation
c is a sequence of pairs of nodes that describe triangles that the
c given node belongs to.  if the given node belongs to a quad, GETNODITET1
c (different form GETNODITET) assigns the triangle formed with the two
c edge neighbours in the quad.)

      ntri=0
      nqud=0
      do i=1,nelements
         if (itettyp(i).eq.ifelmtri) then
            ntri=ntri+1
         elseif (itettyp(i).eq.ifelmqud) then
            nqud=nqud+1
         endif
      enddo

      nsimp=4*nqud+3*ntri

      call mmgetblk('noditet',isubname,ipnoditet,2*nsimp,1,icscode)
      call mmgetblk('noditetoff',isubname,ipnoditetoff,mpno+1,1
     &   ,icscode)

      call getnoditet1(itet,itetoff,itettyp,mpary,mpno,
     &   nelements,nnodes,noditet,noditetoff)

c... elliptic smoothing iterations.

      do iter=1,maxiter_sm
         err=0.

         do k=1,mpno
            nod1=mpary(k)
            if (itp1(nod1).eq.0) then
               xnew=0.
               ynew=0.
               znew=0.
               weight=0.
               x1=xic(nod1)
               y1=yic(nod1)
               z1=zic(nod1)
               nnitet=noditetoff(k+1)-noditetoff(k)
               do i=1,nnitet
                  nod2=noditet(1,noditetoff(k)+i)
                  nod3=noditet(2,noditetoff(k)+i)
                  x2=xic(nod2)
                  y2=yic(nod2)
                  z2=zic(nod2)
                  x3=xic(nod3)
                  y3=yic(nod3)
                  z3=zic(nod3)
                  area(1)=crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
                  area(2)=crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
                  area(3)=crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
                  asq=area(1)**2+area(2)**2+area(3)**2
                  dsq=(xic(nod1)-xic(nod2))**2+
     &               (yic(nod1)-yic(nod2))**2+
     &               (zic(nod1)-zic(nod2))**2
                  dsq=max(epsilonl**2,dsq)
                  wt=max(epsilonl**2,asq/dsq)
                  xnew=xnew+wt*xic(nod2)
                  ynew=ynew+wt*yic(nod2)
                  znew=znew+wt*zic(nod2)
                  weight=weight+wt

                  dsq=(xic(nod1)-xic(nod3))**2+
     &               (yic(nod1)-yic(nod3))**2+
     &               (zic(nod1)-zic(nod3))**2
                  dsq=max(epsilonl**2,dsq)
                  wt=max(epsilonl**2,asq/dsq)
                  xnew=xnew+wt*xic(nod3)
                  ynew=ynew+wt*yic(nod3)
                  znew=znew+wt*zic(nod3)
                  weight=weight+wt
               enddo

               xnew=xnew/weight
               ynew=ynew/weight
               znew=znew/weight
               xold=xic(nod1)
               yold=yic(nod1)
               zold=zic(nod1)
               if (ctrl.gt.zero) then
                  xic(nod1)  = xnew*(1.-ctrl)+xsave(k)*ctrl
                  yic(nod1)  = ynew*(1.-ctrl)+ysave(k)*ctrl
                  zic(nod1)  = znew*(1.-ctrl)+zsave(k)*ctrl
               else
                  xic(nod1)  = xnew
                  yic(nod1)  = ynew
                  zic(nod1)  = znew
               endif

               err=err+(xic(nod1)-xold)**2+
     &            (yic(nod1)-yold)**2+(zic(nod1)-zold)**2
            endif
         enddo

         err=sqrt(err/mpno)

         write(logmess,'(a,i4,a,e14.7)')
     *      'Iteration=',iter,'; root mean square error=',err
         call writloga('default',0,logmess,0,ierrw)

         if (iter.eq.1) then
            err1=err
         else
            if (err.le.err1*.01) goto 9000
         endif

      enddo

c     work out areas of smoothed elements.

 9000 continue

      areamin=1.d99
      areamax=-1.d99
      areaminp=1.d99
      areamaxp=-1.d99
      do i=1,nelements
         ioff=itetoff(i)
         nod1=itet(1+ioff)
         nod2=itet(2+ioff)
         nod3=itet(3+ioff)
         x1=xic(nod1)
         y1=yic(nod1)
         z1=zic(nod1)
         x2=xic(nod2)
         y2=yic(nod2)
         z2=zic(nod2)
         x3=xic(nod3)
         y3=yic(nod3)
         z3=zic(nod3)
         tni(1)=crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(2)=crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         tni(3)=crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         if (itettyp(i).eq.ifelmqud) then
            nod4=itet(4+ioff)
            x1=xic(nod3)
            y1=yic(nod3)
            z1=zic(nod3)
            x2=xic(nod4)
            y2=yic(nod4)
            z2=zic(nod4)
            x3=xic(nod1)
            y3=yic(nod1)
            z3=zic(nod1)
            tni(1)=tni(1)+crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(2)=tni(2)+crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)
            tni(3)=tni(3)+crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)
         endif

         dcross=sqrt(tni(1)**2+tni(2)**2+tni(3)**2)

         areamin=min(areamin,dcross*0.5)
         areamax=max(areamax,dcross*0.5)

         dcrossp=tni(1)*tn1(1)+tni(2)*tn1(2)+tni(3)*tn1(3)

         areaminp=min(areaminp,dcrossp*0.5)
         areamaxp=max(areamaxp,dcrossp*0.5)

      enddo

      write(logmess,'(2(a,e14.7))')
     *   ' min/max area after smoothing=',areamin,' / ',areamax
      call writloga('default',0,logmess,0,ierrw)
      write(logmess,'(2(a,e14.7))')
     *   ' min/max projected area after smoothing=',
     &   areaminp,' / ',areamaxp
      call writloga('default',0,logmess,0,ierrw)

 9999 continue
      call mmrelprt(isubname,icscode)
      return
      end

max_forks_repo_name: daniellivingston/LaGriT


text:
! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Character length mismatch" }

! PR fortran/37746
! Test bounds-checking for string length of dummy arguments.

MODULE m
CONTAINS

  SUBROUTINE test (opt)
    IMPLICIT NONE
    CHARACTER(len=5), OPTIONAL :: opt
  END SUBROUTINE test

END MODULE m

PROGRAM main
  USE m
  IMPLICIT NONE
  CALL test ('') ! 0 length, but not absent argument.
END PROGRAM main

! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" }
! { dg-final { cleanup-modules "m" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
C     *****************************************************************
C     *****************************************************************

      subroutine tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,amax,d,
     +rbdnnz,rbdind,rbdtype,xp,fp,gp,lsinfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer inform,lsinfo,m,nind,rbdnnz
      double precision amax,f,fp

C     ARRAY ARGUMENTS
      integer rbdind(nind)
      character rbdtype(nind)
      logical equatn(m),linear(m)
      double precision d(nind),g(*),gp(*),l(nind),lambda(m),rho(m),
     +        u(nind),x(*),xp(*)

C     This subroutine computes a line search in direction d.
C
C     lsinfo:
C
C     At the first trial:
C
C     5: x + amax d is at the boundary and f(x + amax d) is smaller than f

C     Extrapolation:
C
C     2: Unbounded objective function?
C     4: beta-condition holds. No extrapolation is done
C     6: Maximum number of extrapolations reached
C     7: Similar consecutive projected points
C     8: Not-well-defined objective function
C     9: Functional value increases

C     Backtracking:
C
C     0: Armijo satisfied
C     1: Small step with functional value similar to the current one
C     2: Unbounded objective function?
C     3: Too small backtracking step. Wrong gradient?

      include "dim.par"
      include "machconst.inc"
      include "algconst.par"
      include "counters.inc"
      include "outtyp.inc"

C     LOCAL SCALARS
      logical boundary
      integer i
      double precision alpha,dsupn,gtd,xsupn

C     EXTERNAL SUBROUTINES
      external calcal,csetp

C     ==================================================================
C     ==================================================================

C     Test Armijo condition and beta condition. Decide between accept
C     the first trial, extrapolate or backtrack.

C     ==================================================================
C     ==================================================================

C     ------------------------------------------------------------------
C     Compute directional derivative, dsupn and xsupn
C     ------------------------------------------------------------------

      gtd = 0.0d0
      dsupn = 0.0d0
      xsupn = 0.0d0
      do i = 1,nind
          gtd = gtd + g(i) * d(i)
          dsupn = max( dsupn, abs( d(i) ) )
          xsupn = max( xsupn, abs( x(i) ) )
      end do

      if ( iprintinn .ge. 6 ) then
C          write(*, 100) xsupn,amax,dsupn
          write(10,100) xsupn,amax,dsupn
      end if

C     ------------------------------------------------------------------
C     Compute first trial (projected point)
C     ------------------------------------------------------------------

      alpha = 1.0d0

      boundary = .false.
      do i = 1,nind
          xp(i) = x(i) + d(i)

          if ( xp(i) .lt. l(i) .or. xp(i) .gt. u(i) ) then
              boundary = .true.
              xp(i) = max( l(i), min( xp(i), u(i) ) )
          end if
      end do

      if ( amax .eq. 1.0d0 ) then
          boundary = .true.

          do i = 1,rbdnnz
              if ( rbdtype(i) .eq. 'L' ) then
                  xp(rbdind(i)) = l(rbdind(i))
              else if ( rbdtype(i) .eq. 'U' ) then
                  xp(rbdind(i)) = u(rbdind(i))
              end if
          end do
      end if

      call csetp(nind,xp)

      call calcal(nind,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      if ( .not. boundary ) then

          if ( iprintinn .ge. 6 ) then
C              write(*, 110) fp,fcnt
              write(10,110) fp,fcnt
          end if

      else
          if ( iprintinn .ge. 6 ) then
C              write(*, 120) fp,fcnt
              write(10,120) fp,fcnt
          end if
      end if

C     ------------------------------------------------------------------
C     The first trial is an interior point.
C     ------------------------------------------------------------------

      if ( .not. boundary ) then

          if ( iprintinn .ge. 6 ) then
C              write(*, 140)
              write(10,140)
          end if

C         Armijo condition holds.

          if ( fp .le. f + alpha * gamma * gtd ) then

              if ( iprintinn .ge. 6 ) then
C                  write(*, 150)
                  write(10,150)
              end if

              go to 1000

          end if

C         Armijo condition does not hold. We will do backtracking.

          if ( iprintinn .ge. 6 ) then
C              write(* ,180)
              write(10,180)
          end if

          go to 2000

      end if

C     ------------------------------------------------------------------
C     The first trial is at the boundary.
C     ------------------------------------------------------------------

      if ( iprintinn .ge. 6 ) then
C          write(*, 190)
          write(10,190)
      end if

C     Function value is smaller than at the current point. We will
C     extrapolate.

      if ( fp .lt. f ) then

          if ( iprintinn .ge. 6 ) then
C              write(*, 200)
              write(10,200)
          end if

          go to 1000

      end if

C     Discard the projected point and consider x + amax d

      if ( iprintinn .ge. 6 ) then
C          write(*, 210)
          write(10,210)
      end if

      alpha = amax

      do i = 1,nind
          xp(i) = x(i) + alpha * d(i)
      end do

      do i = 1,rbdnnz
          if ( rbdtype(i) .eq. 'L' ) then
              xp(rbdind(i)) = l(rbdind(i))
          else if ( rbdtype(i) .eq. 'U' ) then
              xp(rbdind(i)) = u(rbdind(i))
          end if
      end do

      call csetp(nind,xp)

      call calcal(nind,xp,m,lambda,rho,equatn,linear,fp,inform)
      if ( inform .lt. 0 ) return

      if ( iprintinn .ge. 6 ) then
C          write(*, 130) alpha,fp,fcnt
          write(10,130) alpha,fp,fcnt
      end if

C     Function value is smaller than or equal to (or even just a little
C     bit greater than) at the current point. Line search is over.

      if ( fp .le. f + macheps23 * abs(f) ) then

          if ( iprintinn .ge. 6 ) then
C              write(*, 220)
              write(10,220)
          end if

          call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
          if ( inform .lt. 0 ) return

          lsinfo = 5

          if ( iprintinn .ge. 6 ) then
C              write(*, 900)
              write(10,900)
          end if

          return

      end if

C     Function value is greater than at the current point. We will
C     do backtracking.

      if ( iprintinn .ge. 6 ) then
C          write(*, 230)
          write(10,230)
      end if

      go to 2000

C     ==================================================================
C     ==================================================================

C     Extrapolation

C     ==================================================================
C     ==================================================================

 1000 continue

      call extrapolation(nind,x,l,u,m,lambda,rho,equatn,linear,g,xp,fp,
     +gp,d,alpha,amax,rbdnnz,rbdind,rbdtype,fmin,beta,etaext,maxextrap,
     +lsinfo,inform)

      return

C     ==================================================================
C     ==================================================================

C     Backtracking

C     ==================================================================
C     ==================================================================

 2000 continue

      call backtracking(nind,x,m,lambda,rho,equatn,linear,f,d,gtd,alpha,
     +fp,xp,calcal,csetp,lsinfo,inform)
      if ( inform .lt. 0 ) return

      call calcnal(nind,xp,m,lambda,rho,equatn,linear,gp,inform)
      if ( inform .lt. 0 ) return

C     ==================================================================
C     End of backtracking
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 100  format(/,5X,'TN Line search (xsupn = ',1P,D7.1,', amax = ',
     +             1P,D7.1,', dsupn = ',1P,D7.1,')')
 110  format(  5X,'Unitary step    F = ',1P,D24.16,' FE = ',I7)
 120  format(  5X,'Projected point F = ',1P,D24.16,' FE = ',I7)
 130  format(  5X,'Alpha = ',1P,D7.1,' F = ',1P,D24.16,' FE = ',I7)
 140  format(  5X,'The first trial is an interior point.')
 150  format(  5X,'Armijo condition holds.')
 180  format(  5X,'Armijo condition does not hold. We will backtrack.')
 190  format(  5X,'The first trial is at the boundary.')
 200  format(  5X,'Function value at the boundary is smaller than at ',
     +            'the current point.',/,5X,'We will extrapolate.')
 210  format(  5X,'Discarding projected point. We will now consider x ',
     +            '+ amax d.')
 220  format(  5X,'Function value at the boundary is smaller than or ',
     +            'equal to than at the',/,5X,'current point. Line ',
     +            'search is over.')
 230  format(  5X,'Function value at the boundary is greater than at ',
     +            'the current point.',/,5X,'We will backtrack.')
 900  format(  5X,'Flag of TN Line search: First trial accepted.')

      end

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
C***********************************************************
      subroutine MOTION(N1,IN,INT,LL,LT, X,AX)
***********************************************************
C   THIS ROUTINE CALCULATES THE MOTION IN ANY TWO SOIL LAYERS OR IN
C   ROCK FROM MOTION GIVEN IN ANY LAYER OR IN ROCK
C
C        N1      = NUMBER OF SOIL LAYERS EXCLUDING ROCK
C        IN      = NUMBER OF LAYER WHERE OBJECT MOTION IS GIVEN
C        INT     = MOTION TYPE
C                  IF EQUEL 0     OUTCROPPING LAYER
C        LL()    = NUMBER OF LAYERS WHERE OUTPUT MOTION IS WANTED
C                  MAX  3 LAYERS
C        LT()    = MOTION TYPE
C                  0 - OUTCROPPING LAYER
C                  1 - LAYER WITHIN PROFILE
C        X()     = OBJECT MOTION
C        AX()    = OUTPUT MOTION
C
C   CODED BY PER B SCHNABEL  OCT 1970
C   modified to increase the number of layers to 50
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
      integer LL(3), LT(3)
      character*6 TITLE,IDNT
      complex AA(3)
      complex X, AX
      complex G, V, PLUS, MINUS
      complex E, F, EE, FF, A, EX, AIN, IPI2
C
      dimension X(300),AX(3,270),S(70)
      common /EQ/ MFOLD,MA2,TITLE(5),DT, MA , MMA, DF,MX
      common /SOILA/ IDNT(6),BL(51),GL(51),FACT(51),H(51),R(51),BF(51)
      common /CSOIL/ G(51), V(51), PLUS(51), MINUS(51)
      common/FRCUT/ NCUT,NZERO
C
      IPI2 = CMPLX(0., 6.283185307)
      do 20 L = 1,3
      if (LL(L) .GT. 0) AX(L,1) = X(1)
      IF(NCUT.EQ.MFOLD) go to 20
      do 30 I=NZERO,MFOLD
      AX(L,I)=CMPLX(0.,0.)
   30 continue
   20 continue
      FREQ = 0.
      do 19 I=2,NCUT
      E = 1.
      FF = 1.
      FREQ = FREQ + DF
      A = FREQ*IPI2
      do 191 K = 1,N1
      if (K.NE.IN) go to 192
      AIN = E + FF
      if (INT.EQ.0) AIN = 2.*E
C   FIND SUBLAYER WHERE MOTION IS WANTED
  192 do 11 L = 1,3
      if (K.NE.LL(L)) go to 11
C   AMPLIFICATION FACTOR FOR SUBLAYER WITHIN PROFILE
      AA(L) = E + FF
C   AMPLIFICATION FACTOR FOR OUTCROPPING SUBLAYER
      if (LT(L).EQ.0)  AA(L) = 2.*E
   11 continue
      EX = CEXP(H(K)*A/V(K))
      EE = E*EX
      F = FF/EX
      E  = EE*PLUS(K) + MINUS(K)*F
      FF = PLUS(K)*F + MINUS(K)*EE
  191 continue
      if (IN.NE.N1+1) go to 193
      AIN = E + FF
      if (INT.EQ.0) AIN = 2.*E
  193 do 21 L = 1,3
      if (LL(L).NE.N1+1) go to 21
      AA(L) = E + FF
      if (LT(L).EQ.0) AA(L) = 2.*E
   21 continue
      do 23 L = 1,3
      if (LL(L) .GT. 0) AX(L,I) = X(I)*AA(L)/AIN
   23 continue
   19 continue
      return
      end


text:
!    file:    euler002.f90
!    author:  Marvin Smith
!    date:    4/25/2015
!
!    Purpose:  Solves Project Euler 002 using Fortran 90
!

PROGRAM Euler002
    USE FibonacciModule
    IMPLICIT none
    INTEGER :: sum, counter, temp_value, max_fib_number, Fmax

!  Set running sum (Start with 2 as that is automatic)
sum = 0

!  Define the max value to find fibonacci numbers for
max_fib_number=4000000

!  Find the max Fn such that it is closest but less than max
Fmax = Find_Max_Fibonacci( max_fib_number )

!  Start Iterating over Fibonacci Values
do counter = 2, Fmax

    !  Call the fibonacci number for the current counter
    temp_value = Fibonacci(counter)

    !  Check if it is even
    if (MODULO(temp_value,2) == 0) then
        sum = sum + temp_value
    endif

end do

!  Print the Sum
print*, sum

!  Exit Program
end

max_stars_repo_name: marvins/ProjectEuler

max_issues_repo_name: marvins/ProjectEuler

max_forks_repo_name: marvins/ProjectEuler