1      SUBROUTINE PSTG3D (LDIMF,MDIMF,F,W)
2C
3C     PACKAGE PSTG3D, VERSION 1, AUGUST 1985
4C
5      DIMENSION       F(LDIMF,MDIMF,*),W(*)
6      L=W(1)
7      LP=W(2)
8      M=W(3)
9      MP=W(4)
10      N=W(5)
11      NP=W(6)
12C
13C     ALLOCATION OF WORK ARRAY W
14C
15      IA=7
16      IC=IA+2*L
17      ICFY=IC+L
18      ICFZ=ICFY+4*M
19      IFCTRD=ICFZ+4*N
20      IWSY=IFCTRD+L*M*N
21      IWSZ=IWSY+M+15
22      IFT=IWSZ+N+15
23C     IEND=IFT+L*M*N
24      GO TO (105,114),LP
25C
26C     REORDER UNKNOWNS WHEN LPEROD = 0.
27C
28  105 LH = (L+1)/2
29      LODD = 1
30      IF (2*LH .EQ. L) LODD = 2
31      DO 111 J=1,M
32         DO 110 K=1,N
33           DO 106 I=1,LH-1
34               W(I+IFT) = F(LH-I,J,K)-F(LH+I,J,K)
35               W(LH+I+IFT) = F(LH-I,J,K)+F(LH+I,J,K)
36  106       CONTINUE
37            W(LH+IFT) = 2.*F(LH,J,K)
38            GO TO (108,107),LODD
39  107       W(L+IFT) = 2.*F(L,J,K)
40  108       DO 109 I=1,L
41               F(I,J,K) = W(I+IFT)
42  109       CONTINUE
43  110    CONTINUE
44  111 CONTINUE
45  114 CONTINUE
46      IF (LDIMF.EQ.L .AND. MDIMF.EQ.M) GO TO 300
47        CALL P3PACK(F,LDIMF,MDIMF,L,M,N,W(IFT))
48      CALL PST3D1 (L,M,MP,N,NP,W(IFT),W(ICFY),W(ICFZ),F,
49     1             W(IA),W(IC),W(IFCTRD),W(IWSY),W(IWSZ))
50        CALL P3UNPK(F,LDIMF,MDIMF,L,M,N,W(IFT))
51       GO TO 400
52  300 CALL PST3D1 (L,M,MP,N,NP,F,W(ICFY),W(ICFZ),W(IFT),
53     *             W(IA),W(IC),W(IFCTRD),W(IWSY),W(IWSZ))
54  400 CONTINUE
55      GO TO (115,122),LP
56  115 DO 121 J=1,M
57         DO 120 K=1,N
58            DO 116 I=1,LH-1
59               W(LH-I+IFT) = .5*(F(LH+I,J,K)+F(I,J,K))
60               W(LH+I+IFT) = .5*(F(LH+I,J,K)-F(I,J,K))
61  116       CONTINUE
62            W(LH+IFT) = .5*F(LH,J,K)
63            GO TO (118,117),LODD
64  117       W(L+IFT) = .5*F(L,J,K)
65  118       DO 119 I=1,L
66               F(I,J,K) = W(I+IFT)
67  119       CONTINUE
68  120    CONTINUE
69  121 CONTINUE
70  122 CONTINUE
71      RETURN
72      END
73