subroutine end(line) * * writes out the model according to the switches (ipn's) that have * been set. [PROFILE: approximately 10% runtime] * implicit double precision(a-h,o-z) common/shells/ sa(400),ra(400),ba(400),pa(400),ta(400), 1 ea(400),xca(400),fca(400),s(400),r(400),b(400), 2 p(400),t(400),e(400),xc(400),sk(400), 3 rk(400),bk(400),pk(400),tk(400) common/coef/hrp(400),hrt(400),hra(400),hbp(400),hbt(400),hba(400), 1 hpp(400),hpt(400),hpa(400),htp(400),htt(400),hta(400) common/contrl/ds,g,sm,wc,it,nite,ja,jb,j,k,l common/times/tmax1,tmax2,tmax3,time,time1,f,dg,dg1,g1,ip5,ip6,ip8 common/vca/modnr common/dvca/sg common/deldg/deldg common/fin/ifin common/tfit/tfit(100),told,ifit,itfit,nite1 common/idone/itconverged common/surf/u(2,3),v(2,3),ww(2,3),rm,bm,is,ks,ls,ms,kstart,npass common/stuck/dgcavg,istuck dimension stash2(8000) dimension x(400,7),y(400,7),z(400,5) equivalence(stash2(1),sa(1)) equivalence (sa(1),x(1,1)),(s(1),y(1,1)),(sk(1),z(1,1)) line = 3 call stitch(hbp(k),hbt(k),hba(k),hrp(k),hrt(k),hra(k),dp2,dt2) jb=k dtmax=0.0 do 611 j=1,jb k=jb-j+1 dr2=hrp(k)*dp2+hrt(k)*dt2+hra(k) db2=hbp(k)*dp2+hbt(k)*dt2+hba(k) s(k)=sk(k) r(k)=rk(k)+f*dr2 b(k)=bk(k)+f*db2 p(k)=pk(k)+f*dp2 t(k)=tk(k)+f*dt2 if(dabs(dtmax).lt.dabs(dt2)) then dtmax=dt2 smax=sk(k) endif dp1=hpp(k)*dp2+hpt(k)*dt2+hpa(k) dt1=htp(k)*dp2+htt(k)*dt2+hta(k) dp2=dp1 dt2=dt1 611 continue nite=nite-1 if ( ip6 ) 706,702,703 702 if ( nite ) 703,703,714 703 continue if ( ip5 .gt. 0 .and. ip6 .gt. 0 ) stop * * Stash the interior shells * Call eprep to calculate converged envelope, store it in aa, * and write it to tape50! * 706 if(nite .le. 0 ) then bl=dlog10(b(jb)) tel=bl/4.-rm/2.+9.18458 if ( (itfit.eq.0 .and. tel.gt.log10(tfit(ifit)) ) .or. 1 abs(10**tel-tfit(ifit)).lt.0.1 ) then told = tel if (itfit.eq.1) then ifit=ifit+1 dg = dg + 0.1 endif itfit=0 istuck=0 else nite = nite1 line = 2 gcor=(10**told-tfit(ifit))/(10**told-10**tel) if (istuck.gt.25 .and. abs(gcor).gt.0.05) then fac=float(istuck-25)/100. gcor=log10(1.+(1.0+fac)*(gcor - 1.)) else gcor=log10(1.+0.40*(gcor - 1.)) endif g = g + gcor itfit=1 istuck=istuck+1 return endif * * Read the interior shells back in! * nshint = jb ifin = 1 write(11) stash2 rewind 11 * * write out model to tape9 * call write3 * * write out complete model to tape 50 * call eprep(nshint) ifin = 0 read(11) stash2 rewind 11 if ( ip8 .ge. 0 ) then pext=10.**(g-g1) call arline(x,y,z,ja,jb,5,ip8,pext) endif call armove(x,y,jb,7) ja=jb if(ip8.gt.0) call armove(y,z,jb,5) line=1 if (tfit(ifit).lt.1.d-03) then itconverged = 1 return endif return endif 714 if ( nite .gt. 1 ) then if ( dabs(dtmax) .ge. tmax1 ) then line=2 return else dg=dmin1(dg1,dg+.5*time) time=dmin1(time1,time+.1) nite = 1 line = 2 return endif else if ( dabs(dtmax) .lt. tmax2 ) then time=time*.8 dg=dg-time modnr = modnr - 1 sg=sg-10.**(g-7.499095) g = g + deldg nite = 1 line = 1 return elseif ( dabs(dtmax) .lt. tmax3 ) then time=time*.8 dg=dg-time modnr = modnr - 1 sg=sg-10.**(g-7.499095) g = g + deldg nite = 1 line = 1 return else modnr = modnr - 1 sg=sg-10.**(g-7.499095) g = g + deldg nite = 1 line = 1 return endif endif end ************************************************************************