Bugfix in AliPoints2Memory

[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / d / epde1.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:18  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE EPDE1
C-----SEGMENT CHANGED FROM PROGRAM TO SUBROUTINE. LIBRARY. APRIL 72.
C
      COMMON  C5     , C95    , NT3    , UT3    , NT4    , HT4
      COMMON  KT4    , NT5    , NE3    , NE4    , NE5    , NC
      COMMON  NR     , KODBAS , DX     , DY     , JOBNUM
      DIMENSION NT3(780),UT3(780),NT4(780),HT4(780,4),KT4(780),
     1NT5(390,2)
      COMMON XDATA(500),YDATA(500) , UDATA(500), NCDATA(500),NBPR(200)
     1     , NBPC(200) ,XB(200,20) , YB(200,20)
      COMMON   UBPR     , UBPC
      DIMENSION  KODBPR(200,20)    , KODBPC(200,20)
      DIMENSION  UBPR(200,20)      , UBPC(200,20)
      EQUIVALENCE (UBPR(1,1),KODBPR(1,1)) , (UBPC(1,1),KODBPC(1,1))
C  THE FOLLOWING STATEMENT IS REQUIRED TO MAKE THE COMMON OF THE MAIN
C  PROGRAM AT LEAST AS LONG AS IN A SUBROUTINE AS PER CERN FORTRAN
      COMMON EXTRA(2271)
      DIMENSION  HL(4) , UL(4)
      EQUIVALENCE (UWANT,NUWANT)
      DIMENSION KSCCP(4,4)
C
      C5=0.0002
      C95=0.9998
      DO 1 I=1,200
      NBPR(I)=0
      NBPC(I)=0
      DO 1 J=1,20
      XB(I,J)=0
      YB(I,J)=0
      UBPR(I,J)=0
    1 UBPC(I,J)=0
      READ 100,DX,DY,NSCC,JOBNUM,KODBAS,NSCCP
      WRITE(6,101)JOBNUM
      IF(NSCCP)3,3,2
    2 READ 104,((KSCCP(I,J),J=1,4),I=1,NSCCP)
    3 KB=0
      DO 11 NCURVE=1,NSCC
      READ 102,NPTS
      KA=KB+1
      KB=KB+NPTS
      READ 107,(XDATA(I),YDATA(I),UDATA(I),NCDATA(I),I=KA,KB)
      DO 23 I=KA,KB
      NEARST=XDATA(I)/DX+0.5
      IF(ABS(XDATA(I)/DX-NEARST)-.00005)20,21,21
   20 XDATA(I)=XDATA(I)+.0001*DX
   21 NEARST=YDATA(I)/DY+0.5
      IF(ABS(YDATA(I)/DY-NEARST)-.00005)22,23,23
   22 YDATA(I)=YDATA(I)+.0001*DY
   23 CONTINUE
      XDATA(KB+1)=XDATA(KA)
      YDATA(KB+1)=YDATA(KA)
      UDATA(KB+1)=UDATA(KA)
      NCDATA(KB+1)=NCDATA(KA)
      DO 10 MP=KA,KB
      LP=MP+1
      CALL EPDBPS(YDATA(MP),YDATA(LP),XDATA(MP),XDATA(LP),UDATA(MP),
     1UDATA(LP),NCDATA(MP),NCDATA(LP),DY,NBPR,XB,UBPR,KODBPR)
      CALL EPDBPS(XDATA(MP),XDATA(LP),YDATA(MP),YDATA(LP),UDATA(MP),
     1UDATA(LP),NCDATA(MP),NCDATA(LP),DX,NBPC,YB,UBPC,KODBPC)
   10 CONTINUE
   11 CONTINUE
      NPTS=KB
      XMAX=XDATA(1)
      DO 6 J=2,NPTS
      IF(XDATA(J)-XMAX)6,6,5
    5 XMAX=XDATA(J)
    6 CONTINUE
      NC=INT(XMAX/DX)+2
      YMAX=YDATA(1)
      DO 8 J=2,NPTS
      IF(YDATA(J)-YMAX)8,8,7
    7 YMAX=YDATA(J)
    8 CONTINUE
      NR=INT(YMAX/DY)+2
      CALL EPDSRT(NR,NBPR,XB,UBPR)
      CALL EPDSRT(NC,NBPC,YB,UBPC)
      NE3=0
      NE4=0
      NE5=0
      DO 30 IR=1,NR
      YM=(IR-1)*DY
      DO 30 IC=1,NC
      NOFPT=(IR-1)*NC+IC
      XM=(IC-1)*DX
      CALL EPDLOC(IR,XM,XB,NBPR,UBPR,HL(3),HL(1),UL(3),UL(1),LX,DX)
      CALL EPDLOC(IC,YM,YB,NBPC,UBPC,HL(4),HL(2),UL(4),UL(2),LY,DY)
      MU=3*LX+LY+1
      GO TO (50,31,33,31,32,33,33,33,34),MU
   50 IF(NSCCP)30,30,51
   51 DO 52 I=1,NSCCP
      IF(KSCCP(I,1)-NOFPT)52,53,52
   52 CONTINUE
      GO TO 30
   53 DO 54 J=1,4
   54 HL(J)=0.0
      J=KSCCP(I,2)
      HL(J)=1.0
      J=KSCCP(I,4)
      HL(J)=1.0
      MKR=3
      NUWANT=KSCCP(I,3)
      GO TO 35
   31 CALL EPDCJ(HL,UL,MKR,UWANT)
      GO TO 35
   32 CALL EPDJE(HL,UL,MKR,UWANT)
      GO TO 35
   33 WRITE(6,103)NOFPT
      RETURN
   34 CALL EPDIN(HL,UL,MKR,UWANT)
   35 CALL EPDTAB(NOFPT,HL,UWANT,MKR,UWANT)
   30 CONTINUE
C*UL 41 IF(NE4)37,37,36
      IF(NE4)37,37,36
   36 CALL EPDCHK(XDATA,YDATA,UDATA,NPTS)
   37 CALL EPDCHN(I,A4)
C         WILL STOP IN EPDCHN, BUT IBM FORTRAN REQUIRES
      RETURN
  101 FORMAT('1 SOLVE ELLIPTIC PARTIAL DIFF. EQUN....JOB NUMBER',I6///)
  102 FORMAT(45X,I5)
  107 FORMAT(3E15.7,I5)
  103 FORMAT('0 COMPUTER CANNOT DECIDE WHETHER POINT NUMBER',I5,
     1       'IS INSIDE OR OUTSIDE THE REGION')
  100 FORMAT(2E15.7,15X,2I5/45X,2I5)
  104 FORMAT(45X,2I5)
      END