Example - user written subroutine

The following code is an example of a complete user written subroutine that applies a heat load to a model. In this case the code looks for elements in a group called 'MID SECTION ELEMENTS' and then applies a heat load that is given by:

where:

• F is a user entered flux.
• A(i) is the area of element i.
• z(i) is the Z-coordinate of the centroid of element i.

The value for the flux is supplied by the user and is entered as TMG variable 0 with I-DEAS TMG.

 SUBROUTINE USER1(gg,t,c,q,qd,r,time,dt,it,
        + kode,nocon,maxno,iconv,dum1,dum2,dtp,tf)
C
C   Arguments
C
        real gg(*), t(*), c(*), q(*), qd(*), r(*)
        real time, dt, dum1, dum2, dtp, tf
        integer it, kode, nocon, maxno, iconv(*)
        character*7 name
C
C   Common block variables
C
        real tdmax, prtflg, params(8000), grav, gv(3), tabs, rgas
        real pstd, tstd, sigma
        integer irun, ir(1), maxn1, maxn2
C
C   Common block definitions
C
        common/tdmax/tdmax
        common/prtflg/prtflg
        common/irun/irun,ir
        common/maxnoq/maxn1,maxn2
        common/params/params
        common/grav/grav,gv,tabs,rgas,pstd,tstd,sigma
C
        save
C   Parameters
C   maxlistlen=maximum number of elements in group
C   maxelem=maximum number of elements in model
C
        integer maxlistlen
        parameter (maxlistlen=2000)
        integer maxelem
        parameter (maxelem=10000)
C
        logical firsttime, active
        data firsttime/.true./
        integer errcount, i, j, n
C
C   Variables for element properties. We must declare
C   all array argument but only need dimension the ones we use.
C
        real geom(3,4,maxelem), prop(10,maxelem), gridloc
        integer gridlist
        real flux
C
C   Variables required for group
C
        integer gid, glength, gnumelem
        character*7 sname
        integer glist(maxlistlen)
C
C
C
        if ( firsttime ) then
C
C   Initialization code goes here
C
C   Check units
C
                if (checkunits) then
                        errcount=errcount+1
                endif
C
                errcount=0
                call longname(sname,'MID SECTION ELEMENTS',gid,glength,2)
                call namar(sname,glist,gnumelem)
                call userarraycheck(maxlistlen,gnumelem,'glist',errcount)
C
C   Get element CG data. Check that array is big enough first.
C
                call userarraycheck(maxelem,maxno,'geom',errcount)
                call readprop2(prop,geom,gridlist,gridloc,'Y','Y','N','N')
C
C   Get flux value
C
                call varval('%TMGVAR0',flux)
                print *,'Applied flux will be ',flux,' times'
                print *,'element Z coordinate'
                print *,' '
C
C   Housing keeping and error checking
C
                firsttime = .false.
                if (errcount .gt. 0) then
                        stop
                endif
        end if
C 
C   Implementation code goes here
C
                if (kode .eq. 1) then
C
C   Apply heat load to all elements in group that
C   is proportional to Z coordinate
C
                do i=1,gnumelem
                        n=glist(i)
                        q(n)=flux*prop(1,n)*geom(3,1,n)
                end do
                endif
        return
        end
        subroutine userarraycheck(arrsize, needsize,arrname, err)
C
C   Checks array size (arrsize) against needed size (needsize) 
C   and increment error counter if array is not large enough. 
C   The arrayname
C   (arrname) is only used for printing diagnostics.
C   Using an error counter means that all arrays can be checked 
C   in a run even if one fails.
C
        integer arrsize, needsize,err
        character*40 arrname
                if (needsize .gt. arrsize) then
                                err=err+1
                                print *,'*** Fatal ***'
                                print *,'Array : ',arrname
                                print *,'Required size is ',needsize
                                print *,'Actual size is ',arrsize
                endif
        return
        end
        logical function checkunits
C
C   This routine checks model units against an internal set
C   of values. The tolerance for units checking is defined
C   by parameter unitstol. It returns false if there are no
C   problems
C
        real unitscheck(5), unitstol
        parameter (unitstol=0.01)
C   Define SI units
        data unitscheck/1.0,1.0,1.0,-273.15,1.0/
C
        real uvals(5), xunits
        integer idum
        logical unitserror
C
C
      call tunits(idum,uvals(1), uvals(2), uvals(3), uvals(4),
     + uvals(5))
C
C   Check each unit for error, allow a tolerance of 1%
C
        unitserror=.false.
        do i=1,5
                xunits=abs((uvals(i)/unitscheck(i))-1)
                if(xunits .gt. unitstol) then
                        unitserror=.true.
                        print *,' '
                        print *,'FATAL ERROR – wrong runtime units selected'
                        print *,' '
                end if
        enddo
        checkunits=unitserror
        return
        end