home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / fchek284.zip / test / noblanks.f < prev    next >
Text File  |  1994-11-06  |  3KB  |  123 lines
  1.       doubleprecisionfunctiondnrm2(n,dx,incx)
  2.       integernext
  3.       doubleprecisiondx(1),cutlo,cuthi,hitest,sum,xmax,zero,one
  4.       datazero,one/0.0d0,1.0d0/
  5. c
  6. c     euclideannormofthen-vectorstoredindx()withstorage
  7. c     incrementincx.
  8. c     ifn.le.0returnwithresult=0.
  9. c     ifn.ge.1thenincxmustbe.ge.1
  10. c
  11. c     c.l.lawson,1978jan08
  12. c
  13. c     fourphasemethodusingtwobuilt-inconstantsthatare
  14. c     hopefullyapplicabletoallmachines.
  15. c     cutlo=maximumofdsqrt(u/eps)overallknownmachines.
  16. c     cuthi=minimumofdsqrt(v)overallknownmachines.
  17. c     where
  18. c     eps=smallestno.suchthateps+1..gt.1.
  19. c     u=smallestpositiveno.(underflowlimit)
  20. c     v=largestno.(overflowlimit)
  21. c
  22. c     briefoutlineofalgorithm..
  23. c
  24. c     phase1scanszerocomponents.
  25. c     movetophase2whenacomponentisnonzeroand.le.cutlo
  26. c     movetophase3whenacomponentis.gt.cutlo
  27. c     movetophase4whenacomponentis.ge.cuthi/m
  28. c     wherem=nforx()realandm=2*nforcomplex.
  29. c
  30. c     valuesforcutloandcuthi..
  31. c     fromtheenvironmentalparameterslistedintheimslconverter
  32. c     documentthelimitingvaluesareasfollows..
  33. c     cutlo,s.p.u/eps=2**(-102)forhoneywell.closesecondsare
  34. c     univacanddecat2**(-103)
  35. c     thuscutlo=2**(-51)=4.44089e-16
  36. c     cuthi,s.p.v=2**127forunivac,honeywell,anddec.
  37. c     thuscuthi=2**(63.5)=1.30438e19
  38. c     cutlo,d.p.u/eps=2**(-67)forhoneywellanddec.
  39. c     thuscutlo=2**(-33.5)=8.23181d-11
  40. c     cuthi,d.p.sameass.p.cuthi=1.30438d19
  41. c     datacutlo,cuthi/8.232d-11,1.304d19/
  42. c     datacutlo,cuthi/4.441e-16,1.304e19/
  43.       datacutlo,cuthi/8.232d-11,1.304d19/
  44. c
  45.       if(n.gt.0)goto10
  46.       dnrm2=zero
  47.       goto300
  48. c
  49.    10 assign30tonext
  50.       sum=zero
  51.       nn=n*incx
  52. c     beginmainloop
  53.       i=1
  54.    20 gotonext,(30,50,70,110)
  55.    30 if(dabs(dx(i)).gt.cutlo)goto85
  56.       assign50tonext
  57.       xmax=zero
  58. c
  59. c     phase1.sumiszero
  60. c
  61.    50 if(dx(i).eq.zero)goto200
  62.       if(dabs(dx(i)).gt.cutlo)goto85
  63. c
  64. c     prepareforphase2.
  65.       assign70tonext
  66.       goto105
  67. c
  68. c     prepareforphase4.
  69. c
  70.   100 i=j
  71.       assign110tonext
  72.       sum=(sum/dx(i))/dx(i)
  73.   105 xmax=dabs(dx(i))
  74.       goto115
  75. c
  76. c     phase2.sumissmall.
  77. c     scaletoavoiddestructiveunderflow.
  78. c
  79.    70 if(dabs(dx(i)).gt.cutlo)goto75
  80. c
  81. c     commoncodeforphases2and4.
  82. c     inphase4sumislarge.scaletoavoidoverflow.
  83. c
  84.   110 if(dabs(dx(i)).le.xmax)goto115
  85.       sum=one+sum*(xmax/dx(i))**2
  86.       xmax=dabs(dx(i))
  87.       goto200
  88. c
  89.   115 sum=sum+(dx(i)/xmax)**2
  90.       goto200
  91. c
  92. c
  93. c     prepareforphase3.
  94. c
  95.    75 sum=(sum*xmax)*xmax
  96. c
  97. c
  98. c     forrealord.p.sethitest=cuthi/n
  99. c     forcomplexsethitest=cuthi/(2*n)
  100. c
  101.    85 hitest=cuthi/float(n)
  102. c
  103. c     phase3.sumismid-range.noscaling.
  104. c
  105.       do95j=i,nn,incx
  106.       if(dabs(dx(j)).ge.hitest)goto100
  107.    95 sum=sum+dx(j)**2
  108.       dnrm2=dsqrt(sum)
  109.       goto300
  110. c
  111.   200 continue
  112.       i=i+incx
  113.       if(i.le.nn)goto20
  114. c
  115. c     endofmainloop.
  116. c
  117. c     computesquarerootandadjustforscaling.
  118. c
  119.       dnrm2=xmax*dsqrt(sum)
  120.   300 continue
  121.       return
  122.       end
  123.