1 subroutine dia_report_file(opt,fil,lfn) 2c 3c $Id$ 4c 5 implicit none 6c 7#include "dia_common.fh" 8#include "dia_params.fh" 9#include "mafdecls.fh" 10c 11 character*8 opt 12 character*255 fil 13 integer lfn 14c 15 integer i,j,num,numi,numj 16 integer i_ii,l_ii,i_ic,l_ic 17 integer i_ji,l_ji,i_jc,l_jc,i_jr,l_jr 18c 19 if(me.ne.0) return 20c 21 if(opt.eq.'local '.and.index(fil,'.loc').gt.0) then 22 open(unit=lfn,file=fil(1:index(fil,' ')-1)) 23 rewind(lfn) 24 read(lfn,1000) num 25 1000 format(i7) 26 read(lfn,1000) numi 27 do 1 i=1,numi 28 read(lfn,1000) j 29 1 continue 30 read(lfn,1000) numj 31 if(.not.ma_push_get(mt_int,3*numi,'ii',l_ii,i_ii)) 32 + call md_abort('Could not allocate ii',0) 33 if(.not.ma_push_get(mt_byte,12*numi,'ic',l_ic,i_ic)) 34 + call md_abort('Could not allocate ic',0) 35 if(.not.ma_push_get(mt_int,4*numj,'ji',l_ji,i_ji)) 36 + call md_abort('Could not allocate ji',0) 37 if(.not.ma_push_get(mt_byte,12*numj,'jc',l_jc,i_jc)) 38 + call md_abort('Could not allocate jc',0) 39 if(.not.ma_push_get(mt_dbl,numj,'jr',l_jr,i_jr)) 40 + call md_abort('Could not allocate jr',0) 41 call dia_report_loc(lfn,numi,numj,int_mb(i_ii),int_mb(i_ji), 42 + byte_mb(i_ic),byte_mb(i_jc),dbl_mb(i_jr)) 43 if(.not.ma_pop_stack(l_jr)) 44 + call md_abort('Failed to deallocate jr',0) 45 if(.not.ma_pop_stack(l_jc)) 46 + call md_abort('Failed to deallocate jc',0) 47 if(.not.ma_pop_stack(l_ji)) 48 + call md_abort('Failed to deallocate ji',0) 49 if(.not.ma_pop_stack(l_ic)) 50 + call md_abort('Failed to deallocate ic',0) 51 if(.not.ma_pop_stack(l_ii)) 52 + call md_abort('Failed to deallocate ii',0) 53 close(unit=lfn) 54 endif 55c 56 return 57 end 58 subroutine dia_report_loc(lfn,numi,numj,ndxi,ndxj,itxt,jtxt,tim) 59c 60 implicit none 61c 62#include "dia_common.fh" 63#include "dia_params.fh" 64c 65 integer lfn,numi,numj 66 integer ndxi(numi,3),ndxj(numj,4) 67 character*12 itxt(numi),jtxt(numj) 68 real*8 tim(numj) 69c 70 integer i,j,k,nskip,it,jt(10) 71 real*8 ctime,ptime,dtime,timi,timf 72c 73 rewind(lfn) 74 read(lfn,1000) j 75 read(lfn,1000) j 76 1000 format(i7) 77 do 1 i=1,numi 78 read(lfn,1001) (ndxi(i,j),j=1,3),itxt(i) 79 1001 format(i7,i5,i6,1x,a12) 80 1 continue 81 read(lfn,1000) j 82 do 2 i=1,numj 83 read(lfn,1001) (ndxj(i,j),j=1,3),jtxt(i) 84 2 continue 85 nskip=numi+numj+3 86c 87 do 3 i=1,numi 88 rewind(lfn) 89 do 4 j=1,nskip 90 read(lfn,1000,end=3) k 91 4 continue 92 do 6 j=1,numj 93 ndxj(j,4)=0 94 tim(j)=0.0d0 95 6 continue 96 ptime=-1.0d0 97 timi=0.0d0 98 5 continue 99 read(lfn,1002,end=11) ctime,it,(jt(k),k=1,10) 100 1002 format(f12.6,i6,10i6) 101 if(ptime.le.0.0d0) timi=ctime 102 if(timf.lt.ctime) timf=ctime 103 if(it.ne.ndxi(i,1)) goto 5 104c 105 if(ptime.ge.0.0d0) then 106 dtime=ctime-ptime 107 do 7 j=1,numj 108 if(ndxj(j,4).ne.0) tim(j)=tim(j)+dtime 109 7 continue 110 endif 111c 112 do 8 j=1,numj 113 ndxj(j,4)=0 114 8 continue 115 ptime=ctime 116c 117 do 9 k=1,10 118 if(jt(k).eq.0) goto 9 119 do 10 j=1,numj 120 if(ndxj(j,1).eq.jt(k)) ndxj(j,4)=1 121 10 continue 122 9 continue 123c 124 goto 5 125 11 continue 126c 127 dtime=ctime-ptime 128 do 12 j=1,numj 129 if(ndxj(j,4).ne.0) tim(j)=tim(j)+dtime 130 12 continue 131c 132 do 13 j=1,numj 133 if(tim(j).gt.0.0d0) then 134 write(6,1003) ndxi(i,3),itxt(i), 135 + ndxj(j,3),jtxt(j),tim(j),100.0d0*tim(j)/(timf-timi) 136 1003 format(i7,1x,a,i7,1x,a,f12.6,' ps = ',f6.2,' %') 137 endif 138 13 continue 139 write(6,1004) 140 1004 format(' ') 141c 142 3 continue 143c 144 return 145 end 146