Deprecated: The each() function is deprecated. This message will be suppressed on further calls in /home/zhenxiangba/zhenxiangba.com/public_html/phproxy-improved-master/index.php on line 456
implicit none real :: pitch,k,m(60000),saisyou,referline,span,mm(60000),r(60000,2) real :: e,l,el1(90000,2),el2(90000,2),elb,ras,height(90000),ri,rii,ame integer :: i,data,ios,data2 character(2) :: dirnamere character(4) :: csv character(9) :: filecsv2 character(9) :: filecsv4 character(1000) :: filename,filecsv,dirname,dirname2 character(1000) :: linebuf,linebuf2,linebuf3,s,inout print *,'算術平均粗さ(mm)を求め，算出するファイルの余分な"0"をカットします。' print *,'このプログラムでは表面の傾き，うねりを補正しません。' print *,"算術平均粗さを求めたいファイル名の入力（拡張子不要）" read *,filename !!!!!!!!!!!!!!!!!!!測定ピッチの変更はこちら!!!!!!!!!!!!!!!! pitch=2.5 !!!!!!!!!!!!!!!!!!!変更ここまで!!!!!!!!!!!!!!!!!!!!!!!!!!!! csv='.csv' filecsv=trim(adjustl(filename))//csv filecsv2='test1.csv' print *,"測定ピッチ(mm)は",pitch call chdir(dirname) open(11,file = filecsv) do i=1,60000 k=0 read(11,*,iostat=ios),k if(ios < 0)exit if(k == 0)exit m(i)=k data=i end do close(11) saisyou=0 do i=1,data saisyou=saisyou+m(i) end do referline=saisyou/data print *,"平均線は：",referline span=pitch*(data-1) print *,"測定スパン(mm)は：",span do i=1,data mm(i)=0 mm(i)=(m(i)-referline) end do open(12,file = filecsv2,status='replace') do i=1,data if( i == data )then write(linebuf,*),mm(i),',',pitch*(i-1) call del_spaces(linebuf) write(12,'(A)'),trim(linebuf) else if( (mm(i) == 0).and.(mm(i+1) == 0) )then write(linebuf,*),mm(i),',',pitch*(i-1) call del_spaces(linebuf) write(12,'(A)'),trim(linebuf) else if( (mm(i) < 0).and.(mm(i+1) < 0) )then write(linebuf,*),mm(i),',',pitch*(i-1) call del_spaces(linebuf) write(12,'(A)'),trim(linebuf) else if( (mm(i) > 0).and.(mm(i+1) > 0) )then write(linebuf,*),mm(i),',',pitch*(i-1) call del_spaces(linebuf) write(12,'(A)'),trim(linebuf) else write(linebuf,*),mm(i),',',pitch*(i-1) call del_spaces(linebuf) write(12,'(A)'),trim(linebuf) write(linebuf2,*),0,',',pitch*(i-1) call del_spaces(linebuf2) write(12,'(A)'),trim(linebuf2) end if end if end if end if end do close(12) open(13,file = filecsv2,status='old') do i=1,90000 e=0 l=0 read(13,*,iostat=ios),e,l if(ios < 0)exit el1(i,1)=e el1(i,2)=l data2=i end do close(13) el2(1,1)=el1(1,1) el2(1,2)=el1(1,2) el2(data2,1)=el1(data2,1) el2(data2,2)=el1(data2,2) do i=2,data2-1 elb=0 if( (el1(i-1,1) /= 0).and.(el1(i,1) == 0).and.(el1(i+1,1) /= 0) )then elb=abs(el1(i-1,1))/( abs(el1(i-1,1))+abs(el1(i+1,1)) ) el2(i,1)=el1(i,1) el2(i,2)=el1(i,2)+(pitch*elb) else el2(i,1)=el1(i,1) el2(i,2)=el1(i,2) end if end do filecsv4='test2.csv' open(14,file =filecsv4,status='replace') do i=1,data2 write(linebuf3,*),el2(i,1),',',el2(i,2) call del_spaces(linebuf3) write(14,'(A)'),trim(linebuf3) end do close(14) do i=1,data2-1 height(i)=el2(i+1,2)-el2(i,2) end do ras=0 do i=1,data-1 ri=0 rii=0 ri=abs(el2(i,1)) rii=abs(el2(i+1,1)) ras=ras+( ri+rii )*height(i)/2 end do ame=ras/span print *,"算術平均粗さRa(mm)は：",ame end !日本NAG fortranTip集 !http://www.nag-j.co.jp/fortran/tips/code/write-nospace-csv.f90 より引用 subroutine del_spaces(s) character (*), intent (inout) :: s character (len=len(s)) tmp integer i, j j = 1 do i = 1, len(s) if (s(i:i)==' ') cycle tmp(j:j) = s(i:i) j = j + 1 end do s = tmp(1:j-1) end subroutine del_spaces