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 |
---|