ASC2EPH修改且漢化

C **********************************************************************************<br />C PARAMETER ( NRECL = 4 )!基本是用重定義輸入<br />C PARAMETER ( NRECL = 1 )!所以最好直接設定或改HEAER<br />C **********************************************************************************<br />CLinyee2011-05修改<br />C增加NRECL參數 增加了檔案名稱參數 增加了資料轉換自動適應能力。增加了檔案自動尋找轉換功能。<br />C與官方最大的不同是，可以直接放到DE405目錄下執行 ASC2EPH < header.405<br />C可以直接產生HEAER中指定的檔案名稱JPLEPH.EPH，唯一需要的是將header.405第一行修改成下邊的形式<br />C---------------------------------------------------------------<br />CKSIZE= 2036 NCOEFF= 1018 NRECL= 4 JPLEPH.EPH<br />C 20 ascp1600.405 ascp2200.405<br />C 00 ascp1600.405 ascp2200.405<br />C---------------------------------------------------------------<br />CKSIZE= 1456 NCOEFF= 728 NRECL= 4 JPLEPH.EPH<br />C -100 ascm3000.406 ascm0100.406<br />C 100 ascp0000.406 ascp2900.406<br />C---------------------------------------------------------------<br />C轉換以後只原本1/3不到的資料大小。第二行是第一步循回。第三行是第二次循回。不用時00。<br />C要用時就根據實際設定比如DE406設為-100，即公元前及公元後。兩組。<br />C單個檔案小點操作比較快，所以本法比原法用COPY產生新.405再轉換會快非常多。<br />C **********************************************************************************<br />C---------------------------------------------------------------<br />!主程式開始<br />C---------------------------------------------------------------</p><p>!定義部分+++++++++++++++++</p><p> IMPLICIT NONE</p><p> CHARACTER*6 CNAM (400)<br /> CHARACTER*6 TTL (14,3)<br /> CHARACTER*12 HEADER<br /> CHARACTER*20 DFEFLE!檔案名稱<br /> CHARACTER*4 ASCNME(6), ASCNM2(6)<br /> CHARACTER*12 ASCFNM(2)!起始終止檔案名稱</p><p> DOUBLE PRECISION AU<br /> DOUBLE PRECISION CVAL (400)<br /> DOUBLE PRECISION DB(3000)<br /> DOUBLE PRECISION DB2Z<br /> DOUBLE PRECISION EMRAT<br /> DOUBLE PRECISION SS (3)<br /> DOUBLE PRECISION T1, T2</p><p> INTEGER ASCLEN, ASCSTT, ASCEND, ASCLE2, ASCST2, ASCEN2<br /> INTEGER DFENCO, DFEBLK<br /> INTEGER I, IPT (3,12), IRECSZ, IN<br /> INTEGER J<br /> INTEGER K,KK,KP2,KSIZE<br /> INTEGER LPT (3)<br /> INTEGER N, NCON, NROUT, NCOEFF, NRW, NUMDE<br /> INTEGER NRECL<br /> INTEGER OUT</p><p> LOGICAL FIRST, IWHILE,FTRUE<br /> DATA FIRST / .TRUE. /<br /> DATA FTRUE / .TRUE. /</p><p>C PARAMETER ( NRECL = 4 )!基本是用重定義輸入<br />C PARAMETER ( NRECL = 1 )!所以最好直接設定或修HEAER</p><p> db2z=0.d0!起始儒略日<br /> T1 = 0.D0<br /> T2 = 9999999.d0!儒略日最大限制</p><p> !代碼部分+++++++++++++++++</p><p> write(*,*) ' JPL ASCII-TO-DIRECT-I/O 程式. ' //<br /> & ' 最後修改 2011-05.'<br /> write(*,*)'Linyee 修改兼漢化，NRECL參數改為HEADER檔案中擷取'</p><p> !讀取參數+++++++++++++++++<br />C 讀取main ephemeris格式大小的記錄.(從 header.xxx)</p><p> !跳過6個字元取6位元整數並輸入!NRECL=4<br /> READ (*,'(6X,I6,2(11X,I6),A20)') KSIZE,DFENCO,NRECL,DFEFLE<br /> WRITE (*,100) KSIZE,DFENCO,NRECL,DFEFLE<br />100 FORMAT(/'KSIZE =',I6,' DFENCOEFF=',I6,' NRECL=',I6,a20)</p><p> IRECSZ = NRECL * KSIZE!單元模組大小 文本1位元組 二進位VFT預設4位元組一單元<br /> !stop 'debug'<br /> !開啟檔案+++++++++++++++++<br />!檔案號12,JPLEPH檔案名稱,任意讀寫,二進位方式,模組大小</p><p> OPEN ( UNIT = 12,<br /> . FILE = DFEFLE,<br /> . ACCESS = 'DIRECT',<br /> . FORM = 'UNFORMATTED',<br /> . RECL = 1,<br /> . STATUS = 'REPLACE' )<br />!NEW OLD REPLACE UNKNOW SCRATCH ,SEQUENTIAL DIRECT,UNFORMATTED FORMATTED<br /> WRITE (12,REC=1,IOSTAT=OUT) (DB(K),K=1,1)<br /> HEADER=''<br /> read(12,REC=1,IOSTAT=IN) HEADER<br /> DFEBLK=len_trim(HEADER)<br /> write (*,*) "預設單元大小：" ,DFEBLK</p><p>!重新開啟檔案<br /> CLOSE (12)<br />IRECSZ=IRECSZ / DFEBLK<br /> OPEN ( UNIT = 12,<br /> . FILE = DFEFLE,<br /> . ACCESS = 'DIRECT',<br /> . FORM = 'UNFORMATTED',<br /> . RECL = IRECSZ,<br /> . STATUS = 'REPLACE' )<br /> WRITE (12,REC=1,IOSTAT=OUT) (DB(K),K=1,1)<br /> !stop 'debug'</p><p>!檔案名稱自適應功能<br /> READ (*,'(I8,3a4,4x,3a4)') ASCLEN,ASCNME!每行一讀<br /> read(ASCNME(2),*) ASCSTT!當前檔案號<br /> read(ASCNME(5),*) ASCEND!終止檔案號</p><p>Write(ASCFNM(1),'(a4,i4.4,a4)') ASCNME(1),ASCSTT,ASCNME(3)<br /> ASCFNM(2)=ASCNME(4) // ASCNME(5) // ASCNME(6)</p><p> WRITE (*,'(3a15)') '起始-終止檔案名稱:',ASCFNM(1),ASCFNM(2)<br /> WRITE (*,*)ASCLEN</p><p> READ (*,'(I8,3a4,4x,3a4)') ASCLE2,ASCNM2!每行一讀<br /> ASCFNM(1)=ASCNM2(1) // ASCNM2(2) // ASCNM2(3)<br /> ASCFNM(2)=ASCNM2(4) // ASCNM2(5) // ASCNM2(6)</p><p> read(ASCNM2(2),*) ASCST2!當前檔案號<br /> read(ASCNM2(5),*) ASCEN2!終止檔案號<br /> WRITE (*,'(3a15)') '起始-終止檔案名稱:',ASCFNM(1),ASCFNM(2)<br /> WRITE (*,*)ASCLE2</p><p>!stop "debug"</p><p>!檢測參數<br /> if(nrecl .ne. 1 .and. nrecl .ne. 4) then<br /> write(*,*)'*** 錯誤: 未設定或使用了未定義的 NRECL ***'<br /> stop<br /> endif</p><p>!讀(GROUP 1010)組.並輸出</p><p> CALL NXTGRP ( HEADER )<br /> IF (HEADER .NE. 'GROUP 1010') THEN<br /> CALL ERRPRT ( 1010, '未找到組號' )<br /> ENDIF</p><p> READ (*,'(14A6)') TTL<br /> WRITE(*,'(/(14A6))') TTL</p><p>!讀(GROUP 1030)組.三個資料開始儒略日，結束日，資料區塊長度</p><p> CALL NXTGRP ( HEADER )<br /> IF ( HEADER .NE. 'GROUP 1030' ) THEN<br /> CALL ERRPRT ( 1030, '未找到組號' )<br /> ENDIF</p><p> READ (*,'(3D12.0)') SS<br /> WRITE(*,*) SS</p><p>!讀(GROUP 1040)組。名稱</p><p> CALL NXTGRP ( HEADER )<br /> IF ( HEADER .NE. 'GROUP 1040 ') THEN<br /> CALL ERRPRT ( 1040, '未找到組號' )<br /> ENDIF</p><p>!隱式迴圈(I),I=3,11,4即3 7 11三次。<br />!讀取8字元只能存6字元<br /> READ (*,'(I6)') N<br /> READ (*,'(10A8)') (CNAM(I),I=1,N)<br /> !WRITE(*,*) CNAM<br /> NCON = N</p><p>!讀取資料忽略空格。值</p><p> CALL NXTGRP ( HEADER )<br /> IF ( HEADER .NE. 'GROUP 1041' ) THEN<br /> CALL ERRPRT ( 1041, '未找到組號' )<br /> ENDIF</p><p> READ (*,'(I6)') N<br /> READ (*,*) (CVAL(I),I=1,N)</p><p> DO I = 1, N<br /> IF ( CNAM(I) .EQ. 'AU ' ) AU = CVAL(I)<br /> IF ( CNAM(I) .EQ. 'EMRAT ' ) EMRAT = CVAL(I)<br /> IF ( CNAM(I) .EQ. 'DENUM ' ) NUMDE = CVAL(I)<br /> END DO</p><p>!格式輸出最多500行兩列。每列前8為名後為雙精<br /> WRITE (*,'(500(/2(A8,D24.16)))') (CNAM(I),CVAL(I),I=1,N)</p><p>!讀(GROUP 1050)組.13列</p><p> CALL NXTGRP ( HEADER )<br /> IF ( HEADER .NE. 'GROUP 1050' ) THEN<br /> CALL ERRPRT ( 1050, '未找到組號' )<br /> ENDIF</p><p>!每行13列，三行。前12列到IPT，第13列到LPT。<br /> READ (*,'(13I6)') ((IPT(I,J),J=1,12),LPT(I),I=1,3)<br /> WRITE(*,'(/(3I5))') IPT, LPT!輸完第一數再輸第二數.</p><p> !讀取資料+++++++++++++++++<br />!讀(GROUP 1070)組.資料群組</p><p> CALL NXTGRP ( HEADER )<br /> IF ( HEADER .NE. 'GROUP 1070' ) CALL ERRPRT(1070,'未找到組號')<br />C-----------------------------------------------------------------<br />!迴圈讀資料！ASCLEN, ASCSTT, ASCEND<br />C-----------------------------------------------------------------<br /> NROUT = 0<br /> IN = 0<br /> OUT = 0</p><p>!第一循回<br />77if (ASCLEN .NE. 0) then<br />IWHILE =.TRUE.<br />go to 55<br />endif<br />go to 66<br />stop'第一循回失敗轉第二循回'</p><p>55do while(IWHILE)</p><p>Write(ASCFNM(1),'(a4,i4.4,a4)') ASCNME(1),ASCSTT,ASCNME(3)<br />!開啟檔案<br /> OPEN ( UNIT = 22,<br /> . FILE = ASCFNM(1),<br /> . ACCESS = 'SEQUENTIAL',<br /> . FORM = 'FORMATTED',<br /> . IOSTAT = IN,<br />C . RECL = IRECSZ,<br /> . STATUS = 'OLD' )</p><p> if (IN .ne. 0) then<br />call ERRPRT(ASCSTT,ASCFNM(1) // ' 未找到後續資料檔案')<br /> endif<br />C---------------------------------------------------------------------------<br />!檔案記錄遍曆<br />C---------------------------------------------------------------------------<br />!讀資料。記錄號，記錄項。<br /> 11 read(22,'(2i6)',IOSTAT =IN)nrw,ncoeff<br /> if(IN .NE. 0)then<br /> CALL ERRPRT(1070,' 未找到資料區塊')<br /> endif<br /> if(nrw .eq. 0) go to 11</p><p>!讀共1018-1個資料，每行3個。<br /> do k=1,ncoeff,3<br /> kp2=min(k+2,ncoeff)!每行結束號<br /> read(22,*,IOSTAT = IN)(DB(kk),kk=k,kp2)<br /> if(IN .NE. 0)then<br /> CALL ERRPRT(k,' 此條資料讀取錯誤或檔案已結束')<br /> endif<br /> enddo</p><p> DO WHILE ( ( IN .EQ. 0 )<br /> . .AND. ( DB(2) .LT. T2) )</p><p> IF ( 2*NCOEFF .NE. KSIZE ) THEN<br /> CALL ERRPRT(NCOEFF,' 記錄項數，<br /> . 不符合規定大小')<br /> ENDIF</p><p> IF ( (DB(2) .GE. T1) .AND. (DB(1) .GE. DB2Z) ) THEN<br /> IF ( FIRST ) THEN<br /> DB2Z = DB(1)<br /> FIRST = .FALSE.<br /> ENDIF</p><p> IF (DB(1) .NE. DB2Z ) THEN<br /> CALL ERRPRT (NRW, '記錄初始日期錯誤')<br /> ENDIF</p><p> DB2Z = DB(2)!置下一次初始日期<br /> NROUT = NROUT + 1<br />C儲存到檔案<br /> WRITE (12,REC=NROUT+2,IOSTAT=OUT) (DB(K),K=1,NCOEFF)</p><p> IF ( OUT .NE. 0 ) THEN<br /> CALL ERRPRT (NROUT,<br /> & '記錄儲存錯誤')<br /> ENDIF<br />C開始日期，結束日期，日期長度<br /> IF (NROUT .EQ. 1) THEN<br /> SS(1) = DB(1)<br /> SS(3) = DB(2) - DB(1)<br /> ENDIF<br /> SS(2) = DB(2)</p><p>CIF ( NROUT .EQ. 1 ) THEN<br />CWRITE (*,271) NROUT, DB(2)<br />CENDIF<br />271 FORMAT (I6,<br /> & ' 條EPH記錄. 結束JED = ',<br /> & F12.2," :From: ",A12)</p><p>C輸出個位為1的記錄資訊</p><p> IF ( MOD(NROUT,200) .EQ. 1 ) THEN<br /> IF ( DB(1) .GE. T1 ) THEN<br /> WRITE (*,271) NROUT, DB(2),ASCFNM(1)<br /> ELSE<br /> WRITE (*,*) ' 尋找第一記錄中……'<br /> ENDIF<br /> ENDIF</p><p> ENDIF<br />!尋找下一條記錄<br /> READ (22,'(2I6)',IOSTAT =IN) NRW, NCOEFF</p><p> if(IN .eq. 0)then<br /> do k=1,ncoeff,3<br /> kp2=min(k+2,ncoeff)<br /> read(22,*,IOSTAT = IN)(DB(kk),kk=k,kp2)<br />if(IN .NE. 0)then<br /> CALL ERRPRT(k,' 此條資料讀取錯誤或檔案已結束')<br />endif<br /> enddo<br /> endif<br /> END DO</p><p>!下一檔案完全判別<br /> CLOSE (22)<br />ASCSTT=ASCSTT+ASCLEN<br />IWHILE= .FALSE.<br />if ((ASCSTT .GE. ASCEND) .and. (ASCLEN .LT. 0)) then<br /> IWHILE=.true.<br /> endif<br />if ((ASCSTT .LE. ASCEND) .and. (ASCLEN .GT. 0)) then<br /> IWHILE=.true.<br /> endif<br /> END DO</p><p>C---------------------------------------------------------------------------<br />!第二循回<br />C---------------------------------------------------------------------------<br />66if (ASCLE2 .NE. 0) then<br />ASCSTT=ASCST2<br />ASCLEN=ASCLE2<br />ASCEND=ASCEN2<br />ASCNME=ASCNM2</p><p>ASCLE2=0<br /> IWHILE=.true.<br />go to 55<br />endif</p><p>C---------------------------------------------------------------------------<br />!循回結束.<br />C---------------------------------------------------------------------------</p><p>C輸出最後的記錄資訊<br /> WRITE (*,271) NROUT, DB(2),ASCFNM(1)</p><p>C 輸出頭資訊</p><p> NROUT = 1<br /> WRITE(12,REC=1,IOSTAT=OUT) TTL,CNAM,SS,NCON,AU,<br /> & EMRAT,IPT,NUMDE,LPT<br /> IF ( OUT .NE. 0 ) THEN<br /> CALL ERRPRT ( NROUT, '記錄儲存錯誤')<br /> ENDIF</p><p>C 輸出頭資訊中的值表</p><p> NROUT = 2<br /> WRITE(12,REC=2,IOSTAT=OUT)CVAL<br /> IF ( OUT .NE. 0 ) THEN<br /> CALL ERRPRT ( NROUT, '記錄儲存錯誤')<br /> ENDIF</p><p> CLOSE (12)<br /> STOP ' OK'<br /> END<br />C---------------------------------------------------------------<br />!主程式結束<br />C---------------------------------------------------------------</p><p>C---------------------------------------------------------------<br />!輸出錯誤資訊並中止程式<br />C---------------------------------------------------------------<br /> SUBROUTINE ERRPRT (I, MSG)</p><p> CHARACTER*(*) MSG<br /> INTEGER I</p><p> WRITE (*,200) I, MSG<br />200 FORMAT('ERROR #',I8,2X,A50)</p><p> STOP ' ERROR '<br /> END<br />C---------------------------------------------------------------<br />C---------------------------------------------------------------</p><p>C---------------------------------------------------------------<br />!進入下一組資料區<br />!'GROUP 1070'行作為結束行.<br />C---------------------------------------------------------------<br /> SUBROUTINE NXTGRP ( HEADER )</p><p> CHARACTER*(*) HEADER<br /> CHARACTER*12 BLANK</p><p> 44 HEADER = ' '<br /> DO WHILE ( HEADER .EQ. ' ' )!跳過空格行<br /> READ (*,'(A)') HEADER<br /> ENDDO</p><p>READ(HEADER,'(A5)') BLANK!不是組標識再找過<br />if (trim(BLANK) .NE. "GROUP") goto 44</p><p> IF ( HEADER .NE. 'GROUP 1070' )READ (*, '(A)') BLANK!跳過空格</p><p> RETURN<br /> END<br />C---------------------------------------------------------------<br />C---------------------------------------------------------------

 

WINDOWS下直接用 VisualFortran6.5 編譯 DF ASC2eph.f就會產生 ASC2eph.exe

 

然後將程式複製到405 406下，將標頭檔第一行改成

KSIZE= 2036 NCOEFF= 1018 NRECL= 4 JPLEPH.405<br /> 20 ascp1600.405 ascp2200.405<br /> 00 ascp1600.405 ascp2200.405<br />  

 

406改成

KSIZE= 1456 NCOEFF= 728 NRECL= 4 JPLEPH.406<br /> -100 ascm3000.406 ascm0100.406<br /> 100 ascp0000.406 ascp2900.406<br />

 

直接運行 ASC2eph <heaer.405

 

就會根據HEADER前三行聲明產生JPLEPH.405的檔案。每個記錄項大小為 Ksize*4即 NCOEFF*8。雙精確度單項大小。

 

源碼跟程式都上傳到了CSDN資源上。需要可以去找下。