MINICERN/mathlib/gen/u/clebs.F.ori

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:01:45  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE CLEBS(J1,J2,J3,JM1,JM2, JM3,K,M)
  11 C*NS  DIMENSION L1(40),L2(40),IB(40),K(2),LS(40,11),LD(40,6),IIL(40,2),
  12 C*NS F                LLSN(40),LLSD(40),IL(2),LL(40),LR(40,100),LQ(40),
  13       DIMENSION               IB(40),K(2),LS(40,11),LD(40,6),IIL(40,2),
  14      F                LLSN(40),LLSD(40),      LL(40),LR(40,100),LQ(40),
  15      F IS(100),ISK(40),M(41)
  16 C*NS  DIMENSION LR1(40),ICGC(40)
  17       DIMENSION         ICGC(40)
  18       IF((JM1+JM2).NE.JM3)     GO TO 1
  19       CALL U100PR(J3+1,LS(1,1),ID)
  20       CALL U100FC((J3+J1-J2)/2,LS(1,2))
  21       CALL U100FC((J3-J1+J2)/2,LS(1,3))
  22       CALL U100FC((J1+J2-J3)/2,LS(1,4))
  23       CALL U100FC((J3+JM3)/2,LS(1,5))
  24       CALL U100FC((J3-JM3)/2,LS(1,6))
  25       CALL U100FC((J1+J2+J3)/2+1,LS(1,7))
  26       CALL U100FC((J1-JM1)/2,LS(1,8))
  27       CALL U100FC((J1+JM1)/2,LS(1,9))
  28       CALL U100FC((J2-JM2)/2,LS(1,10))
  29       CALL U100FC((J2+JM2)/2,LS(1,11))
  30       DO 2    LZ=1,11
  31       IF (LS(1,LZ) .EQ. (-77))   GO TO 45
  32     2 CONTINUE
  33       CALL VZERO (M,41)
  34       CALL VZERO (LLSN,40)
  35       CALL VZERO (LLSD, 40)
  36       DO 5  J=1,40
  37       DO 5 I=1,6
  38     5 LLSN(J)=LLSN(J)+LS(J,I)
  39       DO 6  J=1,40
  40       DO 6  I=7,11
  41     6 LLSD(J)=LLSD(J)+LS(J,I)
  42       CALL U100DV(LLSN,LLSD,LL)
  43       MJ=1
  44       N=-1
  45       MM=0
  46     3 N=N+1
  47       CALL U100FC((J2+J3+JM1)/2-N,LD(1,1))
  48       CALL U100FC((J1-JM1)/2+N,LD(1,2))
  49       CALL U100FC(N,LD(1,3))
  50       CALL U100FC((J3-J1+J2)/2-N,LD(1,4))
  51       CALL U100FC((J3+JM3)/2-N,LD(1,5))
  52       CALL U100FC((J1-J2-JM3)/2+N,LD(1,6))
  53       IF(LD(1,1).EQ.(-77))    GO TO 4
  54       IF(LD(1,4).EQ.(-77))    GO TO 4
  55       IF(LD(1,5).EQ.(-77))    GO TO 4
  56       IF(LD(1,2).EQ.(-77))  GO TO 3
  57       IF(LD(1,6).EQ.(-77))  GO TO 3
  58       MM=MM+1
  59       IS(MM)=(-1)**(N+(J2+JM2)/2)
  60       DO 7    JK=1,40
  61       IIL(JK,1)=LD(JK,1)+LD(JK,2)
  62     7 IIL(JK,2)=LD(JK,3)+LD(JK,4)+LD(JK,5)+LD(JK,6)
  63       CALL U100DV (IIL(1,1),IIL(1,2),LR(1,MM))
  64       GO TO 3
  65     4 DO 31 JJ=1,40
  66       IB(JJ)=10000
  67       DO 31  JK=1,MM
  68       IF (LR(JJ,JK) .LT. IB(JJ))   IB(JJ)=LR(JJ,JK)
  69    31 CONTINUE
  70       ISUM=0
  71       DO 32 JM=1,MM
  72       DO 33 IO=1,40
  73    33 LQ(IO)=LR(IO,JM)-IB(IO)
  74       CALL U100PM(LQ,K(1),K(2))
  75    32 ISUM=ISUM+K(1)*IS(JM)
  76       IX=ABS(ISUM)
  77       IF(IX.EQ.0) GO TO 1
  78       CALL U100PR(IX,ISK,IP)
  79       DO 22 LK=1,40
  80    22 ICGC(LK)=LL(LK)+2*IB(LK)+2*ISK(LK)
  81       IXX=IP*   ISUM/ABS(ISUM)
  82       ISIGN=ISUM/ABS(ISUM)
  83       IXXX=IP*ISIGN
  84       M(41)=IXXX
  85       CALL UCOPY (ICGC, M, 40)
  86       CALL U100PM(ICGC,K(1),K(2))
  87       K(1)=K(1)*IXX
  88       RETURN
  89    45 WRITE(6,50)
  90    50 FORMAT(1H ,'CHECK YOUR PARAMETERS ONCE MORE'///)
  91     1 K(1)=0
  92       K(2)=1
  93       RETURN
  94       END