← Back to branch summary

~ubuntu-branches/ubuntu/wily/julia/wily

« back to all changes in this revision

Viewing changes to deps/openlibm/slatec/reort.f

  • Committer: Package Import Robot
  • Author(s): Sébastien Villemot
  • Date: 2013-01-16 12:29:42 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130116122942-x86e42akjq31repw
Tags: 0.0.0+20130107.gitd9656f41-1
* New upstream snashot
* No longer try to rebuild helpdb.jl.
   + debian/rules: remove helpdb.jl from build-arch rule
   + debian/control: move back python-sphinx to Build-Depends-Indep
* debian/copyright: reflect upstream changes
* Add Build-Conflicts on libatlas3-base (makes linalg tests fail)
* debian/rules: replace obsolete USE_DEBIAN makeflag by a list of
  USE_SYSTEM_* flags
* debian/rules: on non-x86 systems, use libm instead of openlibm
* dpkg-buildflags.patch: remove patch, applied upstream
* Refreshed other patches

Show diffs side-by-side

added added

removed removed

Lines of Context:
deps/openlibm/slatec/reort.f
 
1
*DECK REORT
 
2
      SUBROUTINE REORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA,
 
3
     +   IFLAG)
 
4
C***BEGIN PROLOGUE  REORT
 
5
C***SUBSIDIARY
 
6
C***PURPOSE  Subsidiary to BVSUP
 
7
C***LIBRARY   SLATEC
 
8
C***TYPE      SINGLE PRECISION (REORT-S, DREORT-D)
 
9
C***AUTHOR  Watts, H. A., (SNLA)
 
10
C***DESCRIPTION
 
11
C
 
12
C **********************************************************************
 
13
C   INPUT
 
14
C *********
 
15
C     Y, YP and YHP = homogeneous solution matrix and particular
 
16
C                     solution vector to be orthonormalized.
 
17
C     IFLAG = 1 --  store YHP into Y and YP, test for
 
18
C                   reorthonormalization, orthonormalize if needed,
 
19
C                   save restart data.
 
20
C             2 --  store YHP into Y and YP, reorthonormalization,
 
21
C                   no restarts.
 
22
C                   (preset orthonormalization mode)
 
23
C             3 --  store YHP into Y and YP, reorthonormalization
 
24
C                   (when INHOMO=3 and X=XEND).
 
25
C **********************************************************************
 
26
C   OUTPUT
 
27
C *********
 
28
C     Y, YP = orthonormalized solutions.
 
29
C     NIV = number of independent vectors returned from DMGSBV.
 
30
C     IFLAG = 0 --  reorthonormalization was performed.
 
31
C            10 --  solution process must be restarted at the last
 
32
C                   orthonormalization point.
 
33
C            30 --  solutions are linearly dependent, problem must
 
34
C                   be restarted from the beginning.
 
35
C     W, P, IP = orthonormalization information.
 
36
C **********************************************************************
 
37
C
 
38
C***SEE ALSO  BVSUP
 
39
C***ROUTINES CALLED  MGSBV, SDOT, STOR1, STWAY
 
40
C***COMMON BLOCKS    ML15TO, ML18JR, ML8SZ
 
41
C***REVISION HISTORY  (YYMMDD)
 
42
C   750601  DATE WRITTEN
 
43
C   890531  Changed all specific intrinsics to generic.  (WRB)
 
44
C   890831  Modified array declarations.  (WRB)
 
45
C   890921  Realigned order of variables in certain COMMON blocks.
 
46
C           (WRB)
 
47
C   891214  Prologue converted to Version 4.0 format.  (BAB)
 
48
C   900328  Added TYPE section.  (WRB)
 
49
C   910722  Updated AUTHOR section.  (ALS)
 
50
C***END PROLOGUE  REORT
 
51
C
 
52
      DIMENSION Y(NCOMP,*),YP(*),W(*),S(*),P(*),IP(*),
 
53
     1          STOWA(*),YHP(NCOMP,*)
 
54
C
 
55
C **********************************************************************
 
56
C
 
57
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC
 
58
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
 
59
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
 
60
      COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ,
 
61
     1                INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC,
 
62
     2                ICOCO
 
63
C
 
64
C **********************************************************************
 
65
C***FIRST EXECUTABLE STATEMENT  REORT
 
66
      NFCP=NFC+1
 
67
C
 
68
C     CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED
 
69
C
 
70
      IF (IFLAG .NE. 1) GO TO 5
 
71
      KNSWOT=KNSWOT+1
 
72
      IF (KNSWOT .GE. NSWOT) GO TO 5
 
73
      IF ((XEND-X)*(X-XOT) .LT. 0.) RETURN
 
74
    5 CALL STOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0)
 
75
C
 
76
C     ****************************************
 
77
C
 
78
C     ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y
 
79
C     AND PARTICULAR SOLUTION YP.
 
80
C
 
81
      NIV=NFC
 
82
      CALL MGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,WCND)
 
83
C
 
84
C     ****************************************
 
85
C
 
86
C  CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS.
 
87
C
 
88
      IF (MFLAG .EQ. 0)  GO TO 25
 
89
      IF (IFLAG .EQ. 2) GO TO 15
 
90
      IF (NSWOT .GT. 1  .OR.  LOTJP .EQ. 0) GO TO 20
 
91
   15 IFLAG=30
 
92
      RETURN
 
93
C
 
94
C     RETRIEVE DATA FOR A RESTART AT LAST ORTHONORMALIZATION POINT
 
95
C
 
96
   20 CALL STWAY(Y,YP,YHP,1,STOWA)
 
97
      LOTJP=1
 
98
      NSWOT=1
 
99
      KNSWOT=0
 
100
      MNSWOT=MNSWOT/2
 
101
      TND=TND+1.
 
102
      IFLAG=10
 
103
      RETURN
 
104
C
 
105
C     ****************************************
 
106
C
 
107
   25 IF (IFLAG .NE. 1) GO TO 60
 
108
C
 
109
C     TEST FOR ORTHONORMALIZATION
 
110
C
 
111
      IF (WCND .LT. 50.*TOL) GO TO 60
 
112
      DO 30 IJK=1,NFCP
 
113
      IF (S(IJK) .GT. 1.0E+20) GO TO 60
 
114
   30 CONTINUE
 
115
C
 
116
C     USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE NORM
 
117
C     DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION CHECKPOINT.
 
118
C     OTHER CONTROLS ON THE NUMBER OF STEPS TO THE NEXT CHECKPOINT
 
119
C     ARE ADDED FOR SAFETY PURPOSES.
 
120
C
 
121
      NSWOT=KNSWOT
 
122
      KNSWOT=0
 
123
      LOTJP=0
 
124
      WCND=LOG10(WCND)
 
125
      IF (WCND .GT. TND+3.) NSWOT=2*NSWOT
 
126
      IF (WCND .GE. PWCND) GO TO 40
 
127
      DX=X-PX
 
128
      DND=PWCND-WCND
 
129
      IF (DND .GE. 4) NSWOT=NSWOT/2
 
130
      DNDT=WCND-TND
 
131
      IF (ABS(DX*DNDT) .GT. DND*ABS(XEND-X)) GO TO 40
 
132
      XOT=X+DX*DNDT/DND
 
133
      GO TO 50
 
134
   40 XOT=XEND
 
135
   50 NSWOT=MIN(MNSWOT,NSWOT)
 
136
      PWCND=WCND
 
137
      PX=X
 
138
      RETURN
 
139
C
 
140
C     ****************************************
 
141
C
 
142
C     ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE HOMOGENEOUS
 
143
C     SOLUTION VECTORS AND CHANGE W ACCORDINGLY.
 
144
C
 
145
   60 NSWOT=1
 
146
      KNSWOT=0
 
147
      LOTJP=1
 
148
      KK = 1
 
149
      L=1
 
150
      DO 70 K = 1,NFCC
 
151
      SRP=SQRT(P(KK))
 
152
      IF (INHOMO .EQ. 1) W(K)=SRP*W(K)
 
153
      VNORM=1./SRP
 
154
      P(KK)=VNORM
 
155
      KK = KK + NFCC + 1 - K
 
156
      IF (NFC .EQ. NFCC) GO TO 63
 
157
      IF (L .NE. K/2) GO TO 70
 
158
   63 DO 65 J = 1,NCOMP
 
159
   65 Y(J,L) = Y(J,L)*VNORM
 
160
      L=L+1
 
161
   70 CONTINUE
 
162
C
 
163
      IF (INHOMO .NE. 1  .OR.  NPS .EQ. 1)  GO TO 100
 
164
C
 
165
C     NORMALIZE THE PARTICULAR SOLUTION
 
166
C
 
167
      YPNM=SDOT(NCOMP,YP,1,YP,1)
 
168
      IF (YPNM .EQ. 0.0)  YPNM = 1.0
 
169
      YPNM = SQRT(YPNM)
 
170
      S(NFCP) = YPNM
 
171
      DO 80 J = 1,NCOMP
 
172
   80 YP(J) = YP(J) / YPNM
 
173
      DO 90 J = 1,NFCC
 
174
   90 W(J) = C * W(J)
 
175
C
 
176
  100 IF (IFLAG .EQ. 1) CALL STWAY(Y,YP,YHP,0,STOWA)
 
177
      IFLAG=0
 
178
      RETURN
 
179
      END