Screamer Project  V3.3.1
Screamer Structure
 All Files Functions Variables
mkpfffl.f
Go to the documentation of this file.
1  subroutine pffvals
2 c
3 c----Subroutine Summary--------------------------------------------------
4 c
5 c Purpose: Creates PFF file which contains the points for the
6 c pff requests.
7 c
8 c Author: Kelley L. Fugelso, 1265 (SEA) 26-mar-1991
9 c
10 c Source File: mkpfffl.f
11 c
12 c Modifications:
13 c 1997-08-13 MLK: Create filename based on 'base_filename'
14 c 2014-02-06 RBS: Changed real*4 to real
15 c 2014-05-02 RBS: Changed integer*4 to integer
16 c
17 c----Include Files--------------------------------------------------------
18 c
19  include 'zdemparm.h'
20  include 'zdempprm.h'
21  include 'zdemmax.h'
22  include 'zdemout.h'
23  include 'zdemcomm.h'
24  include 'zdemenv.h'
25 c
26 c-----Local Variables-----------------------------------------------------
27 c
28  character*80 desc !* Comment for PFF dataset */
29  character*60 pff_file, !* PFF file name */
30  + scrname !* Contains symbls set in SCREAMER.COM*/
31  character*15 st
32  character*5 t1, !* Branch # of current variable */
33  + t2 !* Block # of current variable */
34  integer whstep(maxout), hfstep(maxout)
35  integer fid, ispare(5)
36  integer no_text
37  parameter(no_text = 0)
38  real pff_array(max_plot_points)
39  integer tflag(maxout)
40  integer pfuopn, idlist(3)
41 c
42 c----FORMAT Statements-----------------------------------------------------
43 c
44 1000 format (' ',a)
45 1001 format (' ',a28,5x,a)
46 1002 format (' ',a,10x,a)
47 1003 format (' ',a8,5x,a)
48 c
49 c----Subroutine Body-------------------------------------------------------
50 c
51 c Create the name for the PFF file
52 c
53  pff_file = base_filename
54  call strip(pff_file,is1,ie1)
55  iend1 = ie1 - is1 + 5
56  iend2 = iend1 + 1
57  pff_file(1:iend1) = pff_file(is1:ie1)//'.pff'
58  pff_file(iend2:60) = ' '
59 c
60 c Clear the output buffers, calculate the record size of the output
61 c parameter file, and "gather" all of the PFF output requests together.
62 c
63  call clear_outbuf
64  ibufsize = numout*2+2
65  call gather(iouttype, opff, maxout, indices, numpff)
66  do i = 1, numpff
67  tflag(i) = itimeflg(indices(i))
68  enddo
69  tstart = tbegout(indices(1))
70  tstop = tendout(indices(1))
71  nskip = ifsteps(maxfpts, ht, tstart, tstop)
72 c
73  ncycle = 0
74  ipntcnt_wh = 0
75  ipntcnt_hf = 0
76  fflag = oldfile
77  iunit = outunit
78  call open_outfile(iunit, fflag, ierr)
79 c
80 c Gather all PFF requests on the whole time step. Then gather
81 c all PFF requests of the half time step.
82 c
83  call gather(tflag, whole_step, numpff, whstep, numwh)
84  call gather(tflag, half_step, numpff, hfstep, numhf)
85 c
86 c Process all requests on the whole time step
87 c
88  if (numwh .gt. 0) then
89  newrec = 1
90  ipntcnt_wh = 1
91  call read_outfile(iunit, newrec, whole_step,
92  + indices(whstep(1)),
93  + ibufsize, tmptime, tmpval, ierr)
94  timeout(ipntcnt_wh,whstep(1)) = tmptime
95  outdata(ipntcnt_wh,whstep(1)) = tmpval
96  newrec = 0
97  do i = 2, numwh
98  call read_outfile(iunit, newrec, whole_step,
99  + indices(whstep(i)),
100  + ibufsize, tmptime, tmpval, ierr)
101  timeout(ipntcnt_wh,whstep(i)) = tmptime
102  outdata(ipntcnt_wh,whstep(i)) = tmpval
103  enddo
104  newrec = 1
105  call read_outfile(iunit, newrec, whole_step,
106  + indices(whstep(1)),
107  + ibufsize, tmptime, tmpval, ierr)
108  do while (ierr .eq. 0)
109  ncycle = ncycle + 1
110  if (ncycle .ge. nskip) then
111  ipntcnt_wh = ipntcnt_wh + 1
112  timeout(ipntcnt_wh,whstep(1)) = tmptime
113  outdata(ipntcnt_wh,whstep(1)) = tmpval
114  newrec = 0
115  do i = 2, numwh
116  call read_outfile(iunit, newrec, whole_step,
117  + indices(whstep(i)),
118  + ibufsize, tmptime, tmpval, ierr)
119  timeout(ipntcnt_wh,whstep(i)) = tmptime
120  outdata(ipntcnt_wh,whstep(i)) = tmpval
121  enddo
122  ncycle = 0
123  endif
124  newrec = 1
125  call read_outfile(iunit, newrec, whole_step,
126  + indices(whstep(1)),
127  + ibufsize, tmptime, tmpval, ierr)
128  enddo
129  call close_outfile(iunit, ierr)
130  call open_outfile(iunit, fflag, ierr)
131  endif
132 c
133 c Process all requests on the half time step
134 c
135  if (numhf .gt. 0) then
136  ipntcnt_hf = 1
137 c *Read first record to get it out of the way
138  newrec = 1
139  call read_outfile(iunit, newrec, half_step, 1, ibufsize,
140  + tmptime, tmpval, ierr)
141 c *Read first needed record
142  call read_outfile(iunit, newrec, half_step,
143  + indices(hfstep(1)),
144  + ibufsize, tmptime, tmpval, ierr)
145  timeout(ipntcnt_hf,hfstep(1)) = tmptime
146  outdata(ipntcnt_hf,hfstep(1)) = tmpval
147  newrec = 0
148  do i = 2, numhf
149  call read_outfile(iunit, newrec, half_step,
150  + indices(hfstep(i)),
151  + ibufsize, tmptime, tmpval, ierr)
152  timeout(ipntcnt_hf,hfstep(i)) = tmptime
153  outdata(ipntcnt_hf,hfstep(i)) = tmpval
154  enddo
155  newrec = 1
156  call read_outfile(iunit, newrec, half_step,
157  + indices(hfstep(1)),
158  + ibufsize, tmptime, tmpval, ierr)
159  do while (ierr .eq. 0)
160  ncycle = ncycle + 1
161  if (ncycle .ge. nskip) then
162  ipntcnt_hf = ipntcnt_hf + 1
163  timeout(ipntcnt_hf,hfstep(1)) = tmptime
164  outdata(ipntcnt_hf,hfstep(1)) = tmpval
165  newrec = 0
166  do i = 2, numhf
167  call read_outfile(iunit, newrec, half_step,
168  + indices(hfstep(i)),
169  + ibufsize, tmptime, tmpval, ierr)
170  timeout(ipntcnt_hf,hfstep(i)) = tmptime
171  outdata(ipntcnt_hf,hfstep(i)) = tmpval
172  enddo
173  ncycle = 0
174  endif
175  newrec = 1
176  call read_outfile(iunit, newrec, half_step,
177  + indices(hfstep(1)),
178  + ibufsize, tmptime, tmpval, ierr)
179  enddo
180  call close_outfile(iunit,ierr)
181  else
182  call close_outfile(iunit,ierr)
183  endif
184 c
185 c Now write information stored in output arrays to PFF files
186 c
187 c Open PFF file
188 c
189  irwflag = 1
190  ierr = 0
191  idummy = 0
192  call pfsvrb(6,ierr)
193  ierr = 0
194  fid = pfuopn(pff_file, irwflag, ierr, idummy)
195  if (ierr. ne. 0) goto 999
196 c
197  do i = 1, numpff
198 c
199  low = 1
200  if (tflag(i) .eq. whole_step) then
201  imax = ipntcnt_wh
202  ipntcnt = ipntcnt_wh
203  else
204  imax = ipntcnt_hf
205  ipntcnt = ipntcnt_hf
206  endif
207  dx = ht*nskip
208  x0 = timeout(1,i)
209 c
210 c *If user did not enter description, create pff comment
211 c
212  call strip(lblout(indices(i)), istart, iend)
213  if (istart .eq. no_text) then
214 c
215  call int_to_text(ixbrnout(indices(i)), t1)
216  call strip(t1, it11, it12)
217  call int_to_text(ixblkout(indices(i)), t2)
218  call strip(t2, it21, it22)
219  iblock_type = iblkout(i)
220 c
221  if (iblock_type .eq. transline) then
222  desc=lblout_temp(indices(i))(1:23)//':Branch '//
223  + t1(it11:it12)//
224  + ', Block '//t2(it21:it22)//':Transmission line'
225  elseif (iblock_type .eq. pisection) then
226  desc=lblout_temp(indices(i))(1:23)//':Branch '//
227  + t1(it11:it12)//
228  + ', Block '//t2(it21:it22)//':Pi Section'
229  elseif (iblock_type .eq. rcground) then
230  desc=lblout_temp(indices(i))(1:23)//':Branch '//
231  + t1(it11:it12)//
232  + ', Block '//t2(it21:it22)//':RC to Ground'
233  elseif (iblock_type .eq. voltsource) then
234  desc=lblout_temp(indices(i))(1:23)//':Branch '//
235  + t1(it11:it12)//
236  + ', Block '//t2(it21:it22)//':Voltage Source'
237  elseif (iblock_type .eq. vendsource) then
238  desc=lblout_temp(indices(i))(1:23)//':Branch '//
239  + t1(it11:it12)//
240  + ', Block '//t2(it21:it22)//':EOB Voltage Source'
241  elseif (iblock_type .eq. currsource) then
242  desc=lblout_temp(indices(i))(1:23)//':Branch '//
243  + t1(it11:it12)//
244  + ', Block '//t2(it21:it22)//':Current Source'
245  elseif (iblock_type .eq. cendsource) then
246  desc=lblout_temp(indices(i))(1:23)//':Branch '//
247  + t1(it11:it12)//
248  + ', Block '//t2(it21:it22)//':EOB Current Source'
249  elseif (iblock_type .eq. csclsource) then
250  desc=lblout_temp(indices(i))(1:23)//':Branch '//
251  + t1(it11:it12)//
252  + ', Block '//t2(it21:it22)//':EOB SCL Curr.Source'
253  elseif ((iblock_type .eq. mitline) .or.
254  + (iblock_type .eq. pmitline)) then
255  desc=lblout_temp(indices(i))(1:23)//':Branch '//
256  + t1(it11:it12)//
257  + ', Block '//t2(it21:it22)//':MIT Line'
258  elseif (iblock_type .eq. adder) then
259  desc=lblout_temp(indices(i))(1:23)//':Branch '//
260  + t1(it11:it12)//
261  + ', Block '//t2(it21:it22)//':Adder Block'
262  elseif (iblock_type .eq. rlseries) then
263  desc=lblout_temp(indices(i))(1:23)//':Branch '//
264  + t1(it11:it12)//
265  + ', Block '//t2(it21:it22)//':RL in Series'
266  endif
267 c
268 c *If user entered a description, use it for the PFF comment
269 c
270  else
271  call strip(lblout(indices(i)),istart,iend)
272  desc=lblout(indices(i))(istart:iend)
273  endif
274 c
275 c
276 c *Write data for this variable to the PFF file
277 c *Set dummy variables for PFF library call
278 c
279  itap=-3
280  st='SCREAMER Data'
281  nblks=1
282  locb=1
283  idlist(1)=1
284  idlist(2)=ipntcnt
285  idlist(3)=1
286  call pfwuf1(fid,itap,st,desc,nblks,ispare,x0,dx,
287  + xlblout,ylblout(indices(i)),locb,low,imax,idlist,
288  + outdata(1,i),ierr)
289  if (ierr. ne. 0) goto 999
290 c
291  enddo
292 c
293 c Now close the PFF file
294 c
295  call pfucls(fid, ierr)
296 c
297  goto 5000
298 c
299 999 print*,' '
300  print*,' '
301  print*,'>>>>>Error while attempting to open or write to ',
302  + 'PFF file...error=',ierr
303 c
304 c-----End of Subroutine----------------------------------------------------
305 c
306 5000 return
307  end
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character tendout
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character timeout
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c & numout
Definition: zdemout.h:47
subroutine read_outfile(iunit, newrec, timeflag, ipoint, ibufsize, ttime, value, ierr)
Definition: rdoutfl.f:1
subroutine clear_outbuf
Definition: clsoutbf.f:1
subroutine int_to_text(int, text)
Definition: int2txt.f:1
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numpff
Definition: zdemout.h:47
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & ylblout
Definition: zdemout.h:59
subroutine open_outfile(iunit, status, ierr)
Definition: opnoutfl.f:1
subroutine close_outfile(iunit, ierr)
Definition: clsoutfl.f:1
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & ixblkout
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & lblout
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character iouttype
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & outdata
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & lblout_temp
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character indices
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & tbegout
Definition: zdemout.h:59
subroutine strip(text, start, end)
Definition: strpblnk.f:1
subroutine pffvals
Definition: mkpfffl.f:1
c *****************************************************************************c Common blocks for SCREAMER output and tabling c maxout
Definition: zdemout.h:40
integer function ifsteps(maxpts, dt, tstart, tstop)
Definition: findskip.f:1
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & itimeflg
Definition: zdemout.h:59
subroutine gather(inarray, intarget, maxin, outarray, numout)
Definition: gather.f:1
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character ixbrnout
Definition: zdemout.h:59
c *****************************************************************************c Common blocks for SCREAMER output and tabling c numsfc character & iblkout
Definition: zdemout.h:59