1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
SUBROUTINE FRD2A (NQHL,QHR,QHI,IH,NFREQ)
C
INTEGER QHR,QHI,SYSBUF,MCB(7),THR(7),THI(7)
DIMENSION Z(1)
COMMON /ZZZZZZ/ Z
COMMON /SYSTEM/ SYSBUF
COMMON /UNPAKX/ IOUT,INN,NNN,INCR1
COMMON /PACKX / ITI,ITO,II,NN,INCR
C
C FIND COLUMN OF NQHL AND COPY REAL TO QHR AND IMAG TO QHI
C
NZ = KORSZ(Z) - SYSBUF
MCB(1) = NQHL
CALL RDTRL (MCB)
IF (MCB(2) .EQ.0) GO TO 999
IOUT = MCB(5)
ITI = 1
IF (IOUT .EQ. 4) ITI = 2
ITO = ITI
NNN = MCB(3)
INN = 1
INCR1= 1
II = 1
NN = IH
INCR = 2
NWC = 2
IF (IOUT .EQ. 4) NWC = 4
IBUF1 = NZ
IBUF2 = IBUF1 - SYSBUF
CALL OPEN (*999,NQHL,Z(IBUF1),0)
CALL READ (*999,*999,NQHL,Z(1),-2,1,FLAG)
CALL MAKMCB (THR,QHR,IH,MCB(4),ITO)
CALL MAKMCB (THI,QHI,IH,MCB(4),ITO)
CALL SKPREC (NQHL,NFREQ-1)
CALL UNPACK (*25,NQHL,Z(1))
GO TO 30
25 CALL ZEROC (Z,NNN*NWC)
30 J = 1
CALL CLOSE (NQHL,1)
CALL GOPEN (QHR,Z(IBUF2),1)
CALL GOPEN (QHI,Z(IBUF1),1)
DO 40 I = 1,IH
CALL PACK (Z(J),QHR,THR)
CALL PACK (Z(J+1),QHI,THI)
J = J + IH*NWC
40 CONTINUE
CALL CLOSE (QHR,1)
CALL CLOSE (QHI,1)
CALL WRTTRL (THR)
CALL WRTTRL (THI)
CALL DMPFIL (-QHR,Z,NZ)
CALL DMPFIL (-QHI,Z,NZ)
GO TO 1000
999 CALL MAKMCB (THR,QHR,0,0,0)
CALL WRTTRL (THR)
THR(1) = QHI
CALL WRTTRL (THR)
1000 RETURN
END
|
