C C User subroutine vuhard subroutine vuhard ( C Read only - * nblock, * nElement, nIntPt, nLayer, nSecPt, * lAnneal, stepTime, totalTime, dt, cmname, * nstatev, nfieldv, nprops, * props, tempOld, tempNew, fieldOld, fieldNew, * stateOld, * eqps, eqpsRate, C Write only - * yield, dyieldDtemp, dyieldDeqps, * stateNew ) c include 'vaba_param.inc' c dimension nElement(nblock), * props(nprops), * tempOld(nblock), * fieldOld(nblock,nfieldv), * stateOld(nblock,nstatev), * tempNew(nblock), * fieldNew(nblock,nfieldv), * eqps(nblock), * eqpsRate(nblock), * yield(nblock), * dyieldDtemp(nblock), * dyieldDeqps(nblock,2), * stateNew(nblock,nstatev) c parameter ( eqpsFail = 0.25d0 ) c character*80 cmname c ntable = nprops / 8 c do k = 1, nblock call tableLookup ( eqps(k), yield(k), dyieldDeqps(k,1), * ntable, props ) stateNew(k,1) = yield(k) stateNew(k,2) = eqps(k) if ( eqps(k) .gt. eqpsFail ) then stateNew(k,3) = zero end if end do c return end *************************************************************** * tableLookup: Subroutine to lookup function and derivative * * for any given value of the independent variable * *************************************************************** subroutine tableLookup ( var, funct, slope, npoint, curve ) C include 'vaba_param.inc' C parameter ( zero = 0.d0, half = 0.5d0 ) dimension curve(8,npoint) C C curve(1,npoint) is the value of the function; C curve(2,npoint) is the value of the independent variable; C if ( npoint .eq. 1 ) then funct = curve(1,1) slope = zero return end if C C Table lookup C if ( var .lt. curve(2,1) ) then funct = curve(1,1) slope = zero else if ( var .eq. curve(2,1) ) then funct = curve(1,1) slope = half * (curve(1,2)-curve(1,1)) / 1 (curve(2,2)-curve(2,1)) else if ( var .eq. curve(2,npoint) ) then funct = curve(1,npoint) slope = half * (curve(1,npoint)-curve(1,npoint-1)) / 1 (curve(2,npoint)-curve(2,npoint-1)) else if ( var .gt. curve(2,npoint) ) then slope = (curve(1,npoint)-curve(1,npoint-1)) / 1 (curve(2,npoint)-curve(2,npoint-1)) funct = curve(1,npoint)+slope*(var-curve(2,npoint)) else do k = 2, npoint if ( var .lt. curve(2,k) ) then slope = (curve(1,k)-curve(1,k-1))/ 1 (curve(2,k)-curve(2,k-1)) funct = curve(1,k-1)+slope*(var-curve(2,k-1)) go to 20 else if ( var .eq. curve(2,k) ) then slope = half * ( 1 (curve(1,k)-curve(1,k-1))/ 2 (curve(2,k)-curve(2,k-1)) + 3 (curve(1,k+1)-curve(1,k))/ 4 (curve(2,k+1)-curve(2,k)) ) funct = curve(1,k) go to 20 end if end do end if C 20 continue C return end