| 1 | PROGRAM fbcp |
|---|
| 2 | USE obs_fbm |
|---|
| 3 | IMPLICIT NONE |
|---|
| 4 | ! |
|---|
| 5 | ! Command line arguments for output file and input file |
|---|
| 6 | ! |
|---|
| 7 | #ifndef NOIARGCPROTO |
|---|
| 8 | INTEGER,EXTERNAL :: iargc |
|---|
| 9 | #endif |
|---|
| 10 | INTEGER :: nargs |
|---|
| 11 | CHARACTER(len=256) :: cdoutfile |
|---|
| 12 | CHARACTER(len=256) :: cdinfile |
|---|
| 13 | CHARACTER(len=256) :: cdtmp |
|---|
| 14 | INTEGER :: nout,ninn,nadd,next,i,j,k |
|---|
| 15 | LOGICAL :: lgrid |
|---|
| 16 | ! |
|---|
| 17 | ! Feedback data |
|---|
| 18 | ! |
|---|
| 19 | TYPE(obfbdata) :: fbdatain,fbdataout |
|---|
| 20 | ! |
|---|
| 21 | ! Get number of command line arguments |
|---|
| 22 | ! |
|---|
| 23 | nargs=IARGC() |
|---|
| 24 | IF ((nargs < 2)) THEN |
|---|
| 25 | WRITE(*,'(A)')'Usage:' |
|---|
| 26 | WRITE(*,'(A)')'fbcp inputfile outputfile {#outer] [include inner (0/1)] <names of extra fields>' |
|---|
| 27 | CALL abort() |
|---|
| 28 | ENDIF |
|---|
| 29 | CALL getarg(1,cdinfile) |
|---|
| 30 | CALL getarg(2,cdoutfile) |
|---|
| 31 | nout=-1 |
|---|
| 32 | ninn=0 |
|---|
| 33 | IF ( nargs > 2 ) THEN |
|---|
| 34 | CALL getarg(3,cdtmp) |
|---|
| 35 | READ(cdtmp,'(I8)')nout |
|---|
| 36 | IF ( nargs > 3 ) THEN |
|---|
| 37 | CALL getarg(4,cdtmp) |
|---|
| 38 | READ(cdtmp,'(I8)')ninn |
|---|
| 39 | IF ((ninn<0).OR.(ninn>1)) THEN |
|---|
| 40 | WRITE(*,*)'Inner loop switch should be either 0 or 1' |
|---|
| 41 | CALL abort |
|---|
| 42 | ENDIF |
|---|
| 43 | ENDIF |
|---|
| 44 | ENDIF |
|---|
| 45 | ! |
|---|
| 46 | ! Initialize feedback data |
|---|
| 47 | ! |
|---|
| 48 | CALL init_obfbdata( fbdatain ) |
|---|
| 49 | CALL init_obfbdata( fbdataout ) |
|---|
| 50 | ! |
|---|
| 51 | ! Read the file |
|---|
| 52 | ! |
|---|
| 53 | CALL read_obfbdata( TRIM(cdinfile), fbdatain ) |
|---|
| 54 | ! |
|---|
| 55 | ! Copy the file |
|---|
| 56 | ! |
|---|
| 57 | IF ( nout >= 0 ) THEN |
|---|
| 58 | nadd = nout * ( 1 + ninn) + 1 + fbdatain%nadd |
|---|
| 59 | ELSE |
|---|
| 60 | nadd = fbdatain%nadd |
|---|
| 61 | ENDIF |
|---|
| 62 | IF ( nargs > 4 ) THEN |
|---|
| 63 | next = fbdatain%next + ( nargs - 4) |
|---|
| 64 | ELSE |
|---|
| 65 | next = fbdatain%next |
|---|
| 66 | ENDIF |
|---|
| 67 | CALL copy_obfbdata( fbdatain, fbdataout, kadd = nadd, kext = next, & |
|---|
| 68 | & lgrid = (nout >= 0) .OR. fbdatain%lgrid ) |
|---|
| 69 | ! |
|---|
| 70 | ! Set additional names |
|---|
| 71 | ! |
|---|
| 72 | IF ( nout>=0 ) THEN |
|---|
| 73 | k=fbdatain%nadd |
|---|
| 74 | DO j=0,nout |
|---|
| 75 | k=k+1 |
|---|
| 76 | WRITE(fbdataout%caddname(k),'(A,I2.2)')'Hx',j |
|---|
| 77 | IF (j>0) THEN |
|---|
| 78 | DO i=1,ninn |
|---|
| 79 | k=k+1 |
|---|
| 80 | WRITE(fbdataout%caddname(k),'(A,I2.2)')'Hxa',j |
|---|
| 81 | ENDDO |
|---|
| 82 | ENDIF |
|---|
| 83 | ENDDO |
|---|
| 84 | ENDIF |
|---|
| 85 | IF ( nargs > 4 ) THEN |
|---|
| 86 | DO i = 1, nargs - 4 |
|---|
| 87 | CALL getarg(i+4,fbdataout%cextname(i+fbdatain%next)) |
|---|
| 88 | ENDDO |
|---|
| 89 | ENDIF |
|---|
| 90 | ! |
|---|
| 91 | ! Write the file |
|---|
| 92 | ! |
|---|
| 93 | CALL write_obfbdata( TRIM(cdoutfile), fbdataout ) |
|---|
| 94 | |
|---|
| 95 | END PROGRAM fbcp |
|---|
